08/09: Tweak loading package derivations

[Christopher Baines]

cbaines pushed a commit to branch master
in repository data-service.

commit ed974ebf3b9eeb60a6256fb9f2fc654b6e8bd3e2
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Mon Jul 17 13:27:21 2023 +0100

    Tweak loading package derivations
    
    Make sure to log any errors, and also use a more efficient approach sending
    less data to the inferior.
---
 guix-data-service/jobs/load-new-guix-revision.scm | 41 ++++++++++++++++-------
 1 file changed, 28 insertions(+), 13 deletions(-)

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm 
b/guix-data-service/jobs/load-new-guix-revision.scm
index c9408f5..6f61bf4 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -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)))