08/11: gexp: 'gexp-inputs' returns both native and non-native inputs.

[guix-commits]

civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.

commit 5b9dd35c6ffce1c385e7ab793fd89c84c003d874
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Feb 16 21:46:18 2021 +0100

    gexp: 'gexp-inputs' returns both native and non-native inputs.
    
    This avoids double traversal of references and extra bookkeeping,
    thereby further reducing memory allocations.
    
    * guix/gexp.scm (lower-gexp): Include only one call to 'lower-inputs'.
    (gexp-inputs): Remove #:native? parameter.
    [set-gexp-input-native?]: New procedure.
    [add-reference-inputs]: Use it.
    (gexp-native-inputs): Remove.
    * tests/gexp.scm (gexp-native-inputs): Remove.
    (gexp-input->tuple): Include 'gexp-input-native?'.
    ("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  | 31 ++++++++++++-------------------
 tests/gexp.scm | 54 +++++++++++++++++++++---------------------------------
 2 files changed, 33 insertions(+), 52 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 6358a88..6133ab6 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1008,13 +1008,9 @@ derivations--e.g., code evaluated for its side effects."
                        (guile     (if guile-for-build
                                       (return guile-for-build)
                                       (default-guile-derivation system)))
-                       (normals  (lower-inputs (gexp-inputs exp)
+                       (inputs   (lower-inputs (gexp-inputs exp)
                                                #:system system
                                                #:target target))
-                       (natives  (lower-inputs (gexp-native-inputs exp)
-                                               #:system system
-                                               #:target #f))
-                       (inputs -> (append normals natives))
                        (sexp     (gexp->sexp exp
                                              #:system system
                                              #:target target))
@@ -1220,26 +1216,26 @@ The other arguments are as for 'derivation'."
                       #:substitutable? substitutable?
                       #:properties properties))))
 
-(define* (gexp-inputs exp #:key native?)
-  "Return the list of <gexp-input> for EXP.  When NATIVE? is true, return only
-native references; otherwise, return only non-native references."
+(define (gexp-inputs exp)
+  "Return the list of <gexp-input> for EXP."
+  (define set-gexp-input-native?
+    (match-lambda
+      (($ <gexp-input> thing output)
+       (%gexp-input thing output #t))))
+
   (define (add-reference-inputs ref result)
     (match ref
       (($ <gexp-input> (? gexp? exp) _ #t)
-       (if native?
-           (append (gexp-inputs exp)
-                   (gexp-inputs exp #:native? #t)
-                   result)
-           result))
-      (($ <gexp-input> (? gexp? exp) _ #f)
-       (append (gexp-inputs exp #:native? native?)
+       (append (map set-gexp-input-native? (gexp-inputs exp))
                result))
+      (($ <gexp-input> (? gexp? exp) _ #f)
+       (append (gexp-inputs exp) result))
       (($ <gexp-input> (? string? str))
        (if (direct-store-path? str)
            (cons ref result)
            result))
       (($ <gexp-input> (? struct? thing) output n?)
-       (if (and (eqv? n? native?) (lookup-compiler thing))
+       (if (lookup-compiler thing)
            ;; THING is a derivation, or a package, or an origin, etc.
            (cons ref result)
            result))
@@ -1263,9 +1259,6 @@ native references; otherwise, return only non-native 
references."
               '()
               (gexp-references exp)))
 
-(define gexp-native-inputs
-  (cut gexp-inputs <> #:native? #t))
-
 (define (gexp-outputs exp)
   "Return the outputs referred to by EXP as a list of strings."
   (define (add-reference-output ref result)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index f742c5d..0bd1237 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -51,8 +51,6 @@
 ;; For white-box testing.
 (define (gexp-inputs x)
   ((@@ (guix gexp) gexp-inputs) x))
-(define (gexp-native-inputs x)
-  ((@@ (guix gexp) gexp-native-inputs) x))
 (define (gexp-outputs x)
   ((@@ (guix gexp) gexp-outputs) x))
 (define (gexp->sexp . x)
@@ -64,7 +62,8 @@
                   #:guile-for-build (%guile-for-build)))
 
 (define (gexp-input->tuple input)
-  (list (gexp-input-thing input) (gexp-input-output input)))
+  (list (gexp-input-thing input) (gexp-input-output input)
+        (gexp-input-native? input)))
 
 (define %extension-package
   ;; Example of a package to use when testing 'with-extensions'.
@@ -347,7 +346,7 @@
                  (string-append (derivation->output-path drv)
                                 "/bin/touch"))))))
 (test-equal "let-system"
-  (list `(begin ,(%current-system) #t) '(system-binding) '()
+  (list `(begin ,(%current-system) #t) '(system-binding)
         'low '() '())
   (let* ((exp #~(begin
                   #$(let-system system system)
@@ -361,7 +360,6 @@
                   (string=? (gexp-input-output input) "out")
                   '(system-binding)))
             (x x))
-          (gexp-native-inputs exp)
           'low
           (lowered-gexp-inputs low)
           (lowered-gexp-sources low))))
@@ -383,7 +381,6 @@
 (test-equal "let-system, nested"
   (list `(system* ,(string-append "qemu-system-" (%current-system))
                   "-m" "256")
-        '()
         '(system-binding))
   (let ((exp #~(system*
                 #+(let-system (system target)
@@ -398,12 +395,12 @@
                              (basename command))
                        ,@rest))
             (x x))
-          (gexp-inputs exp)
-          (match (gexp-native-inputs exp)
+          (match (gexp-inputs exp)
             ((input)
              (and (eq? (struct-vtable (gexp-input-thing input))
                        (@@ (guix gexp) <system-binding>))
                   (string=? (gexp-input-output input) "out")
+                  (gexp-input-native? input)
                   '(system-binding)))
             (x x)))))
 
@@ -422,31 +419,26 @@
          (bu     (derivation->output-path
                   (package-cross-derivation %store binutils target))))
     (and (lset= equal?
-                `((,%bootstrap-guile "out") (,glibc "out"))
-                (map gexp-input->tuple (gexp-native-inputs exp)))
-         (lset= equal?
-                `((,coreutils "out") (,binutils "out"))
+                `((,%bootstrap-guile "out" #t)
+                  (,coreutils "out" #f)
+                  (,glibc "out" #t)
+                  (,binutils "out" #f))
                 (map gexp-input->tuple (gexp-inputs exp)))
          (equal? `(list ,guile ,cu ,libc ,bu)
                  (gexp->sexp* exp target)))))
 
 (test-equal "ungexp + ungexp-native, nested"
-  (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out")))
+  `((,%bootstrap-guile "out" #f) (,coreutils "out" #t))
   (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils)))
                           (ungexp %bootstrap-guile)))))
-    (list (map gexp-input->tuple (gexp-inputs exp))
-          '<>
-          (map gexp-input->tuple (gexp-native-inputs exp)))))
+    (map gexp-input->tuple (gexp-inputs exp))))
 
 (test-equal "ungexp + ungexp-native, nested, special mixture"
-  `(() <> ((,coreutils "out")))
+  `((,coreutils "out" #t))
 
-  ;; (gexp-native-inputs exp) used to return '(), wrongfully.
   (let* ((foo (gexp (foo (ungexp-native coreutils))))
          (exp (gexp (bar (ungexp foo)))))
-    (list (map gexp-input->tuple (gexp-inputs exp))
-          '<>
-          (map gexp-input->tuple (gexp-native-inputs exp)))))
+    (map gexp-input->tuple (gexp-inputs exp))))
 
 (test-assert "input list"
   (let ((exp   (gexp (display
@@ -456,7 +448,7 @@
         (cu    (derivation->output-path
                 (package-derivation %store coreutils))))
     (and (lset= equal?
-                `((,%bootstrap-guile "out") (,coreutils "out"))
+                `((,%bootstrap-guile "out" #f) (,coreutils "out" #f))
                 (map gexp-input->tuple (gexp-inputs exp)))
          (equal? `(display '(,guile ,cu))
                  (gexp->sexp* exp)))))
@@ -475,10 +467,8 @@
          (xbu   (derivation->output-path
                  (package-cross-derivation %store binutils target))))
     (and (lset= equal?
-                `((,%bootstrap-guile "out") (,coreutils "out"))
-                (map gexp-input->tuple (gexp-native-inputs exp)))
-         (lset= equal?
-                `((,glibc "out") (,binutils "out"))
+                `((,%bootstrap-guile "out" #t) (,coreutils "out" #t)
+                  (,glibc "out" #f) (,binutils "out" #f))
                 (map gexp-input->tuple (gexp-inputs exp)))
          (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
                  (gexp->sexp* exp target)))))
@@ -492,7 +482,7 @@
                          (package-derivation %store %bootstrap-guile))))
          (exp     (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
     (and (lset= equal?
-                `((,glibc "debug") (,%bootstrap-guile "out"))
+                `((,glibc "debug" #f) (,%bootstrap-guile "out" #f))
                 (map gexp-input->tuple (gexp-inputs exp)))
          (equal? (gexp->sexp* exp)
                  `(list ,@(cons 5 outputs))))))
@@ -502,18 +492,16 @@
                        %bootstrap-guile))
          (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
     (and (lset= equal?
-                `((,glibc "debug") (,%bootstrap-guile "out"))
-                (map gexp-input->tuple (gexp-native-inputs exp)))
-         (null? (gexp-inputs exp))
+                `((,glibc "debug" #t) (,%bootstrap-guile "out" #t))
+                (map gexp-input->tuple (gexp-inputs exp)))
          (equal? (gexp->sexp* exp)                ;native
                  (gexp->sexp* exp "mips64el-linux")))))
 
 (test-assert "gexp list splicing + ungexp-splicing"
   (let* ((inner (gexp (ungexp-native glibc)))
          (exp   (gexp (list (ungexp-splicing (list inner))))))
-    (and (equal? `((,glibc "out"))
-                 (map gexp-input->tuple (gexp-native-inputs exp)))
-         (null? (gexp-inputs exp))
+    (and (equal? `((,glibc "out" #t))
+                 (map gexp-input->tuple (gexp-inputs exp)))
          (equal? (gexp->sexp* exp)                ;native
                  (gexp->sexp* exp "mips64el-linux")))))