guix
/
data-service
mirror of git://git.savannah.gnu.org/guix/data-service.git
2
0
Fork 0
Code Issues Releases Wiki Activity

Further tweak loading package derivations 

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