Tweak loading package derivations

Make sure to log any errors, and also use a more efficient approach sending
less data to the inferior.
This commit is contained in:
Christopher Baines 2023-07-17 13:27:21 +01:00
parent 9dec45d2eb
commit ed974ebf3b
1 changed files with 28 additions and 13 deletions

View File

@ -721,8 +721,8 @@ WHERE job_id = $1")
targets)))
cross-derivations))
(define (proc packages system-target-pairs)
`(lambda (store)
(define proc
'(lambda (store system-target-pairs)
(define target-system-alist
(if (defined? 'platforms (resolve-module '(guix platform)))
(filter-map
@ -801,9 +801,13 @@ WHERE job_id = $1")
(derivation-system derivation))
#f)))))
(lambda args
;; misc-error #f ~A ~S (No
;; cross-compilation for
;; clojure-build-system yet:
(simple-format
(current-error-port)
"warning: error when computing ~A derivation for system ~A (~A): ~A\n"
(package-name package)
system
(or target "no target")
args)
#f)))
(append-map
@ -834,10 +838,10 @@ WHERE job_id = $1")
(member system-for-target
(package-supported-systems package)
string=?)))))
(list ,@(map cdr system-target-pairs))))
(map cdr system-target-pairs)))
'())))
(delete-duplicates
(list ,@(map car system-target-pairs))
(map car system-target-pairs)
string=?)))
(lambda (key . args)
(if (and (eq? key 'system-error)
@ -858,13 +862,22 @@ WHERE job_id = $1")
key
args)
'()))))))
(list ,@(map inferior-package-id packages)))))
gds-inferior-package-ids)))
(inferior-eval
'(when (defined? 'systems (resolve-module '(guix platform)))
(use-modules (guix platform)))
inf)
(inferior-eval
`(define gds-inferior-package-ids
(list ,@(map inferior-package-id packages)))
inf)
(inferior-eval
`(define gds-packages-proc ,proc)
inf)
(append-map
(lambda (system-target-pair)
(format (current-error-port)
@ -913,11 +926,13 @@ WHERE job_id = $1")
(/ (inferior-eval '(assoc-ref (gc-stats) 'heap-size) inf)
(expt 2. 20))))
(let ((derivations
(with-time-logging
(simple-format #f "getting derivations for ~A" system-target-pair)
(inferior-eval-with-store inf store (proc packages (list system-target-pair))))))
derivations))
(with-time-logging
(simple-format #f "getting derivations for ~A" system-target-pair)
(inferior-eval-with-store
inf
store
`(lambda (store)
(gds-packages-proc store (list (quote ,system-target-pair)))))))
(append supported-system-pairs
supported-system-cross-build-pairs)))