02/02: Further tweak loading package derivations

[Christopher Baines]

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

commit ef73305250c5ea83fffe393d643597e359eec1e9
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Thu Jul 20 16:31:59 2023 +0100

    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.
---
 guix-data-service/jobs/load-new-guix-revision.scm | 73 +++++++++++++----------
 1 file 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)))