04/10: gexp: 'gexp-inputs' returns a list of <gexp-input> records.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit fc6d6aee6659acb293eb33f498fdac3b47a19a48
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Feb 16 20:54:27 2021 +0100

    gexp: 'gexp-inputs' returns a list of <gexp-input> records.
    
    This slightly reduces memory allocation.
    
    * guix/gexp.scm (lower-inputs): Expect a list of <gexp-input> rather
    than a list of tuples.
    (lower-reference-graphs)[tuple->gexp-input]: New procedure.
    Use it.
    (gexp-inputs): Return a list of <gexp-input> rather than a list of
    tuples.
    * tests/gexp.scm (gexp-input->tuple): New procedure.
    ("one input package")
    ("one input package, dotted list")
    ("one input origin")
    ("one local file")
    ("one local file, symlink")
    ("one plain file")
    ("two input packages, one derivation, one file")
    ("file-append")
    ("file-append, output")
    ("file-append, nested")
    ("let-system")
    ("let-system, nested")
    ("ungexp + ungexp-native")
    ("ungexp + ungexp-native, nested")
    ("ungexp + ungexp-native, nested, special mixture")
    ("input list")
    ("input list + ungexp-native")
    ("input list splicing")
    ("input list splicing + ungexp-native-splicing")
    ("gexp list splicing + ungexp-splicing"): Adjust accordingly.
---
 guix/gexp.scm  | 37 ++++++++++++----------
 tests/gexp.scm | 96 +++++++++++++++++++++++++++++++++++-----------------------
 2 files changed, 79 insertions(+), 54 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 8dd824c..8e80d4a 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -842,24 +842,23 @@ When TARGET is true, use it as the cross-compilation 
target triplet."
   (with-monad %store-monad
     (>>= (mapm/accumulate-builds
           (match-lambda
-            (((? struct? thing) sub-drv ...)
-             (mlet %store-monad ((obj (lower-object
-                                       thing system #:target target)))
+            (($ <gexp-input> (? store-item? item))
+             (return item))
+            (($ <gexp-input> thing output native?)
+             (mlet %store-monad ((obj (lower-object thing system
+                                                    #:target
+                                                    (and (not native?)
+                                                         target))))
                (return (match obj
                          ((? derivation? drv)
-                          (let ((outputs (if (null? sub-drv)
-                                             '("out")
-                                             sub-drv)))
-                            (derivation-input drv outputs)))
+                          (derivation-input drv (list output)))
                          ((? store-item? item)
                           item)
                          ((? self-quoting?)
                           ;; Some inputs such as <system-binding> can lower to
                           ;; a self-quoting object that FILTERM will filter
                           ;; out.
-                          #f)))))
-            (((? store-item? item))
-             (return item)))
+                          #f))))))
           inputs)
          filterm)))
 
@@ -867,9 +866,16 @@ When TARGET is true, use it as the cross-compilation 
target triplet."
   "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
 #:reference-graphs argument, lower it such that each INPUT is replaced by the
 corresponding <derivation-input> or store item."
+  (define tuple->gexp-input
+    (match-lambda
+      ((thing)
+       (%gexp-input thing "out" #t))
+      ((thing output)
+       (%gexp-input thing output #t))))
+
   (match graphs
     (((file-names . inputs) ...)
-     (mlet %store-monad ((inputs (lower-inputs inputs
+     (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs)
                                                #:system system
                                                #:target target)))
        (return (map cons file-names inputs))))))
@@ -1213,9 +1219,8 @@ The other arguments are as for 'derivation'."
                       #:properties properties))))
 
 (define* (gexp-inputs exp #:key native?)
-  "Return the input list for EXP.  When NATIVE? is true, return only native
-references; otherwise, return only non-native references."
-  ;; TODO: Return <gexp-input> records instead of tuples.
+  "Return the list of <gexp-input> for EXP.  When NATIVE? is true, return only
+native references; otherwise, return only non-native references."
   (define (add-reference-inputs ref result)
     (match ref
       (($ <gexp-input> (? gexp? exp) _ #t)
@@ -1229,12 +1234,12 @@ references; otherwise, return only non-native 
references."
                result))
       (($ <gexp-input> (? string? str))
        (if (direct-store-path? str)
-           (cons `(,str) result)
+           (cons ref result)
            result))
       (($ <gexp-input> (? struct? thing) output n?)
        (if (and (eqv? n? native?) (lookup-compiler thing))
            ;; THING is a derivation, or a package, or an origin, etc.
-           (cons `(,thing ,output) result)
+           (cons ref result)
            result))
       (($ <gexp-input> (lst ...) output n?)
        (fold-right add-reference-inputs result
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 6e92f0e..f742c5d 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès 
<ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès 
<ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -63,6 +63,9 @@
                                      #:target target)
                   #:guile-for-build (%guile-for-build)))
 
+(define (gexp-input->tuple input)
+  (list (gexp-input-thing input) (gexp-input-output input)))
+
 (define %extension-package
   ;; Example of a package to use when testing 'with-extensions'.
   (dummy-package "extension"
@@ -106,8 +109,8 @@
   (let ((exp (gexp (display (ungexp coreutils)))))
     (and (gexp? exp)
          (match (gexp-inputs exp)
-           (((p "out"))
-            (eq? p coreutils)))
+           ((input)
+            (eq? (gexp-input-thing input) coreutils)))
          (equal? `(display ,(derivation->output-path
                              (package-derivation %store coreutils)))
                  (gexp->sexp* exp)))))
@@ -116,8 +119,8 @@
   (let ((exp (gexp (coreutils . (ungexp coreutils)))))
     (and (gexp? exp)
          (match (gexp-inputs exp)
-           (((p "out"))
-            (eq? p coreutils)))
+           ((input)
+            (eq? (gexp-input-thing input) coreutils)))
          (equal? `(coreutils . ,(derivation->output-path
                                  (package-derivation %store coreutils)))
                  (gexp->sexp* exp)))))
@@ -126,8 +129,9 @@
   (let ((exp (gexp (display (ungexp (package-source coreutils))))))
     (and (gexp? exp)
          (match (gexp-inputs exp)
-           (((o "out"))
-            (eq? o (package-source coreutils))))
+           ((input)
+            (and (eq? (gexp-input-thing input) (package-source coreutils))
+                 (string=? (gexp-input-output input) "out"))))
          (equal? `(display ,(derivation->output-path
                              (package-source-derivation
                               %store (package-source coreutils))))
@@ -141,8 +145,9 @@
                               "sha256" file)))
     (and (gexp? exp)
          (match (gexp-inputs exp)
-           (((x "out"))
-            (eq? x local)))
+           ((input)
+            (and (eq? (gexp-input-thing input) local)
+                 (string=? (gexp-input-output input) "out"))))
          (equal? `(display ,intd) (gexp->sexp* exp)))))
 
 (test-assert "one local file, symlink"
@@ -158,8 +163,9 @@
                                     "sha256" file)))
           (and (gexp? exp)
                (match (gexp-inputs exp)
-                 (((x "out"))
-                  (eq? x local)))
+                 ((input)
+                  (and (eq? (gexp-input-thing input) local)
+                       (string=? (gexp-input-output input) "out"))))
                (equal? `(display ,intd) (gexp->sexp* exp)))))
       (lambda ()
         (false-if-exception (delete-file link))))))
@@ -201,8 +207,9 @@
          (expected (add-text-to-store %store "hi" "Hello, world!")))
     (and (gexp? exp)
          (match (gexp-inputs exp)
-           (((x "out"))
-            (eq? x file)))
+           ((input)
+            (and (eq? (gexp-input-thing input) file)
+                 (string=? (gexp-input-output input) "out"))))
          (equal? `(display ,expected) (gexp->sexp* exp)))))
 
 (test-assert "same input twice"
@@ -211,8 +218,9 @@
                      (display (ungexp coreutils))))))
     (and (gexp? exp)
          (match (gexp-inputs exp)
-           (((p "out"))
-            (eq? p coreutils)))
+           ((input)
+            (and (eq? (gexp-input-thing input) coreutils)
+                 (string=? (gexp-input-output input) "out"))))
          (let ((e `(display ,(derivation->output-path
                               (package-derivation %store coreutils)))))
            (equal? `(begin ,e ,e) (gexp->sexp* exp))))))
@@ -228,9 +236,8 @@
                       (display (ungexp drv))
                       (display (ungexp txt))))))
     (define (match-input thing)
-      (match-lambda
-       ((drv-or-pkg _ ...)
-        (eq? thing drv-or-pkg))))
+      (lambda (input)
+        (eq? (gexp-input-thing input) thing)))
 
     (and (gexp? exp)
          (= 4 (length (gexp-inputs exp)))
@@ -255,8 +262,9 @@
                       (string-append (derivation->output-path drv)
                                      "/bin/guile"))))
          (match (gexp-inputs exp)
-           (((thing "out"))
-            (eq? thing fa))))))
+           ((input)
+            (and (eq? (gexp-input-thing input) fa)
+                 (string=? (gexp-input-output input) "out")))))))
 
 (test-assert "file-append, output"
   (let* ((drv (package-derivation %store glibc))
@@ -268,8 +276,9 @@
                       (string-append (derivation->output-path drv "debug")
                                      "/lib/debug"))))
          (match (gexp-inputs exp)
-           (((thing "debug"))
-            (eq? thing fa))))))
+           ((input)
+            (and (eq? (gexp-input-thing input) fa)
+                 (string=? (gexp-input-output input) "debug")))))))
 
 (test-assert "file-append, nested"
   (let* ((drv   (package-derivation %store glibc))
@@ -283,8 +292,8 @@
                       (string-append (derivation->output-path drv)
                                      "/bin/getent"))))
          (match (gexp-inputs exp)
-           (((thing "out"))
-            (eq? thing file))))))
+           ((input)
+            (eq? (gexp-input-thing input) file))))))
 
 (test-assert "file-append, raw store item"
   (let* ((obj   (plain-file "example.txt" "Hello!"))
@@ -346,8 +355,11 @@
          (low (run-with-store %store (lower-gexp exp))))
     (list (lowered-gexp-sexp low)
           (match (gexp-inputs exp)
-            (((($ (@@ (guix gexp) <system-binding>)) "out"))
-             '(system-binding))
+            ((input)
+             (and (eq? (struct-vtable (gexp-input-thing input))
+                       (@@ (guix gexp) <system-binding>))
+                  (string=? (gexp-input-output input) "out")
+                  '(system-binding)))
             (x x))
           (gexp-native-inputs exp)
           'low
@@ -388,8 +400,11 @@
             (x x))
           (gexp-inputs exp)
           (match (gexp-native-inputs exp)
-            (((($ (@@ (guix gexp) <system-binding>)) "out"))
-             '(system-binding))
+            ((input)
+             (and (eq? (struct-vtable (gexp-input-thing input))
+                       (@@ (guix gexp) <system-binding>))
+                  (string=? (gexp-input-output input) "out")
+                  '(system-binding)))
             (x x)))))
 
 (test-assert "ungexp + ungexp-native"
@@ -408,10 +423,10 @@
                   (package-cross-derivation %store binutils target))))
     (and (lset= equal?
                 `((,%bootstrap-guile "out") (,glibc "out"))
-                (gexp-native-inputs exp))
+                (map gexp-input->tuple (gexp-native-inputs exp)))
          (lset= equal?
                 `((,coreutils "out") (,binutils "out"))
-                (gexp-inputs exp))
+                (map gexp-input->tuple (gexp-inputs exp)))
          (equal? `(list ,guile ,cu ,libc ,bu)
                  (gexp->sexp* exp target)))))
 
@@ -419,7 +434,9 @@
   (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out")))
   (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils)))
                           (ungexp %bootstrap-guile)))))
-    (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
+    (list (map gexp-input->tuple (gexp-inputs exp))
+          '<>
+          (map gexp-input->tuple (gexp-native-inputs exp)))))
 
 (test-equal "ungexp + ungexp-native, nested, special mixture"
   `(() <> ((,coreutils "out")))
@@ -427,7 +444,9 @@
   ;; (gexp-native-inputs exp) used to return '(), wrongfully.
   (let* ((foo (gexp (foo (ungexp-native coreutils))))
          (exp (gexp (bar (ungexp foo)))))
-    (list (gexp-inputs exp) '<> (gexp-native-inputs exp))))
+    (list (map gexp-input->tuple (gexp-inputs exp))
+          '<>
+          (map gexp-input->tuple (gexp-native-inputs exp)))))
 
 (test-assert "input list"
   (let ((exp   (gexp (display
@@ -438,7 +457,7 @@
                 (package-derivation %store coreutils))))
     (and (lset= equal?
                 `((,%bootstrap-guile "out") (,coreutils "out"))
-                (gexp-inputs exp))
+                (map gexp-input->tuple (gexp-inputs exp)))
          (equal? `(display '(,guile ,cu))
                  (gexp->sexp* exp)))))
 
@@ -457,10 +476,10 @@
                  (package-cross-derivation %store binutils target))))
     (and (lset= equal?
                 `((,%bootstrap-guile "out") (,coreutils "out"))
-                (gexp-native-inputs exp))
+                (map gexp-input->tuple (gexp-native-inputs exp)))
          (lset= equal?
                 `((,glibc "out") (,binutils "out"))
-                (gexp-inputs exp))
+                (map gexp-input->tuple (gexp-inputs exp)))
          (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
                  (gexp->sexp* exp target)))))
 
@@ -474,7 +493,7 @@
          (exp     (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
     (and (lset= equal?
                 `((,glibc "debug") (,%bootstrap-guile "out"))
-                (gexp-inputs exp))
+                (map gexp-input->tuple (gexp-inputs exp)))
          (equal? (gexp->sexp* exp)
                  `(list ,@(cons 5 outputs))))))
 
@@ -484,7 +503,7 @@
          (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
     (and (lset= equal?
                 `((,glibc "debug") (,%bootstrap-guile "out"))
-                (gexp-native-inputs exp))
+                (map gexp-input->tuple (gexp-native-inputs exp)))
          (null? (gexp-inputs exp))
          (equal? (gexp->sexp* exp)                ;native
                  (gexp->sexp* exp "mips64el-linux")))))
@@ -492,7 +511,8 @@
 (test-assert "gexp list splicing + ungexp-splicing"
   (let* ((inner (gexp (ungexp-native glibc)))
          (exp   (gexp (list (ungexp-splicing (list inner))))))
-    (and (equal? `((,glibc "out")) (gexp-native-inputs exp))
+    (and (equal? `((,glibc "out"))
+                 (map gexp-input->tuple (gexp-native-inputs exp)))
          (null? (gexp-inputs exp))
          (equal? (gexp->sexp* exp)                ;native
                  (gexp->sexp* exp "mips64el-linux")))))