diff options
author | Christopher Baines <mail@cbaines.net> | 2023-07-20 16:31:59 +0100 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2023-07-20 16:46:53 +0100 |
commit | ef73305250c5ea83fffe393d643597e359eec1e9 (patch) | |
tree | f76ba0145152ee633f5af9ce8c067f4c9750edbf | |
parent | 6e4d436d7548108f78d279658292f034d447a09e (diff) | |
download | data-service-ef73305250c5ea83fffe393d643597e359eec1e9.tar data-service-ef73305250c5ea83fffe393d643597e359eec1e9.tar.gz |
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.
-rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 73 |
1 files changed, 40 insertions, 33 deletions
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 53e0037..1168f03 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -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))) |