cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Further tweak loading package derivations

Browse source 
There's an issue where sometimes for i686-linux and armhf-linux, only a few
package derivations are computed.

This commit tries to simplify the code, and adds some conditional logging for
the guix package, which might help reveal what's going on.
This commit is contained in:
Christopher Baines 2023-07-20 16:31:59 +01:00
parent 6e4d436d75
commit ef73305250
1 changed files with 40 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

73
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -722,7 +722,7 @@ WHERE job_id = $1")
cross-derivations)) cross-derivations))
(define proc (define proc
'(lambda (store system-target-pairs) '(lambda (store system-target-pair)
(define target-system-alist (define target-system-alist
(if (defined? 'platforms (resolve-module '(guix platform))) (if (defined? 'platforms (resolve-module '(guix platform)))
(filter-map (filter-map
@ -771,7 +771,7 @@ WHERE job_id = $1")
"error ~A: ~A\n" key args) "error ~A: ~A\n" key args)
#f)))) #f))))
(define (derivations-for-system-and-target inferior-package-id package system target) (define (derivation-for-system-and-target inferior-package-id package system target)
(catch (catch
'misc-error 'misc-error
(lambda () (lambda ()
@ -810,39 +810,45 @@ WHERE job_id = $1")
args) args)
#f))) #f)))
(append-map (filter-map
(lambda (inferior-package-id) (lambda (inferior-package-id)
(let ((package (hashv-ref %package-table inferior-package-id))) (let ((package (hashv-ref %package-table inferior-package-id)))
(catch (catch
#t #t
(lambda () (lambda ()
(append-map (let* ((system (car system-target-pair))
(lambda (system) (target (cdr system-target-pair))
(let ((supported-systems (get-supported-systems package system))) (supported-systems (get-supported-systems package system))
(if (and supported-systems (system-supported?
(member system supported-systems)) (and supported-systems
(filter-map (->bool (member system supported-systems))))
(lambda (target) (target-supported?
(derivations-for-system-and-target inferior-package-id (or (not target)
package (let ((system-for-target
system (assoc-ref target-system-alist
target)) target)))
(filter (or (not system-for-target)
(match-lambda (->bool
(#f #t) ; No target (member system-for-target
(target (package-supported-systems package)
(let ((system-for-target string=?)))))))
(assoc-ref target-system-alist
target))) (when (string=? (package-name package) "guix")
(or (not system-for-target) (simple-format
(member system-for-target (current-error-port)
(package-supported-systems package) "looking at guix package (supported systems: ~A, system supported: ~A, target supported: ~A\n"
string=?))))) supported-systems
(map cdr system-target-pairs))) system-supported?
'()))) target-supported?))
(delete-duplicates
(map car system-target-pairs) (if system-supported?
string=?))) (if target-supported?
(derivation-for-system-and-target inferior-package-id
package
system
target)
#f)
#f)))
(lambda (key . args) (lambda (key . args)
(if (and (eq? key 'system-error) (if (and (eq? key 'system-error)
(eq? (car args) 'fport_write)) (eq? (car args) 'fport_write))
@ -861,7 +867,7 @@ WHERE job_id = $1")
(package-name package) (package-name package)
key key
args) args)
'())))))) #f))))))
gds-inferior-package-ids))) gds-inferior-package-ids)))
(inferior-eval (inferior-eval
@ -878,7 +884,7 @@ WHERE job_id = $1")
`(define gds-packages-proc ,proc) `(define gds-packages-proc ,proc)
inf) inf)
(append-map (append-map!
(lambda (system-target-pair) (lambda (system-target-pair)
(format (current-error-port) (format (current-error-port)
"heap size: ~a MiB~%" "heap size: ~a MiB~%"
@ -932,7 +938,8 @@ WHERE job_id = $1")
inf inf
store store
`(lambda (store) `(lambda (store)
(gds-packages-proc store (list (quote ,system-target-pair))))))) (gds-packages-proc store (cons ,(car system-target-pair)
,(cdr system-target-pair)))))))
(append supported-system-pairs (append supported-system-pairs
supported-system-cross-build-pairs))) supported-system-cross-build-pairs)))