[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
07/20: gexp: 'gexp-inputs' returns both native and non-native inputs.
From: |
guix-commits |
Subject: |
07/20: gexp: 'gexp-inputs' returns both native and non-native inputs. |
Date: |
Mon, 1 Mar 2021 09:32:09 -0500 (EST) |
civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.
commit a66101d1b529d19c24d62412b10a24d915a6e70d
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")))))
- branch wip-build-systems-gexp created (now b1da83b), guix-commits, 2021/03/01
- 02/20: packages: Turn 'bag->derivation' into a monadic procedure., guix-commits, 2021/03/01
- 05/20: gexp: Micro-optimize sexp serialization., guix-commits, 2021/03/01
- 04/20: packages: Core procedures are written in monadic style., guix-commits, 2021/03/01
- 01/20: build-system: Rewrite using gexps., guix-commits, 2021/03/01
- 07/20: gexp: 'gexp-inputs' returns both native and non-native inputs.,
guix-commits <=
- 03/20: packages: Simplify patch instantiation., guix-commits, 2021/03/01
- 09/20: gexp: Micro-optimize 'gexp->sexp' and 'lower-inputs'., guix-commits, 2021/03/01
- 12/20: grafts: Inline 'grafting?' and 'set-grafting'., guix-commits, 2021/03/01
- 15/20: serialization: Micro-optimize string literal output in 'write-file-tree'., guix-commits, 2021/03/01
- 16/20: gexp: Optimize 'with-build-variables'., guix-commits, 2021/03/01
- 17/20: packages: Default origin 'patch-flags' is a gexp., guix-commits, 2021/03/01
- 18/20: gexp: Add 'sexp->gexp'., guix-commits, 2021/03/01
- 08/20: gexp: Keep 'lower-inputs' private., guix-commits, 2021/03/01
- 10/20: store: Object cache profiling shows the number of entries., guix-commits, 2021/03/01
- 11/20: gexp: Reduce allocations while traversing lists., guix-commits, 2021/03/01