futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gexp: 'gexp-inputs' returns both native and non-native inputs.

Browse Source 
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.
This commit is contained in:
Ludovic Courtès 2021-02-16 21:46:18 +01:00
parent fc6d6aee66
commit 4fa9d48fd4
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 33 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
guix/gexp.scm
View File

@ -1006,13 +1006,9 @@ derivations--e.g., code evaluated for its side effects."
(guile (if guile-for-build (guile (if guile-for-build
(return guile-for-build) (return guile-for-build)
(default-guile-derivation system))) (default-guile-derivation system)))
(normals (lower-inputs (gexp-inputs exp) (inputs (lower-inputs (gexp-inputs exp)
#:system system #:system system
#:target target)) #:target target))
(natives (lower-inputs (gexp-native-inputs exp)
#:system system
#:target #f))
(inputs -> (append normals natives))
(sexp (gexp->sexp exp (sexp (gexp->sexp exp
#:system system #:system system
#:target target)) #:target target))
@ -1218,26 +1214,26 @@ The other arguments are as for 'derivation'."
#:substitutable? substitutable? #:substitutable? substitutable?
#:properties properties)))) #:properties properties))))
(define* (gexp-inputs exp #:key native?) (define (gexp-inputs exp)
"Return the list of <gexp-input> for EXP. When NATIVE? is true, return only "Return the list of <gexp-input> for EXP."
native references; otherwise, return only non-native references." (define set-gexp-input-native?
(match-lambda
(($ <gexp-input> thing output)
(%gexp-input thing output #t))))
(define (add-reference-inputs ref result) (define (add-reference-inputs ref result)
(match ref (match ref
(($ <gexp-input> (? gexp? exp) _ #t) (($ <gexp-input> (? gexp? exp) _ #t)
(if native? (append (map set-gexp-input-native? (gexp-inputs exp))
(append (gexp-inputs exp)
(gexp-inputs exp #:native? #t)
result)
result))
(($ <gexp-input> (? gexp? exp) _ #f)
(append (gexp-inputs exp #:native? native?)
result)) result))
(($ <gexp-input> (? gexp? exp) _ #f)
(append (gexp-inputs exp) result))
(($ <gexp-input> (? string? str)) (($ <gexp-input> (? string? str))
(if (direct-store-path? str) (if (direct-store-path? str)
(cons ref result) (cons ref result)
result)) result))
(($ <gexp-input> (? struct? thing) output n?) (($ <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. ;; THING is a derivation, or a package, or an origin, etc.
(cons ref result) (cons ref result)
result)) result))
@ -1261,9 +1257,6 @@ native references; otherwise, return only non-native references."
'() '()
(gexp-references exp))) (gexp-references exp)))
(define gexp-native-inputs
(cut gexp-inputs <> #:native? #t))
(define (gexp-outputs exp) (define (gexp-outputs exp)
"Return the outputs referred to by EXP as a list of strings." "Return the outputs referred to by EXP as a list of strings."
(define (add-reference-output ref result) (define (add-reference-output ref result)

54
tests/gexp.scm
View File

@ -51,8 +51,6 @@
;; For white-box testing. ;; For white-box testing.
(define (gexp-inputs x) (define (gexp-inputs x)
((@@ (guix gexp) gexp-inputs) x)) ((@@ (guix gexp) gexp-inputs) x))
(define (gexp-native-inputs x)
((@@ (guix gexp) gexp-native-inputs) x))
(define (gexp-outputs x) (define (gexp-outputs x)
((@@ (guix gexp) gexp-outputs) x)) ((@@ (guix gexp) gexp-outputs) x))
(define (gexp->sexp . x) (define (gexp->sexp . x)
@ -64,7 +62,8 @@
#:guile-for-build (%guile-for-build))) #:guile-for-build (%guile-for-build)))
(define (gexp-input->tuple input) (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 (define %extension-package
;; Example of a package to use when testing 'with-extensions'. ;; Example of a package to use when testing 'with-extensions'.
@ -347,7 +346,7 @@
(string-append (derivation->output-path drv) (string-append (derivation->output-path drv)
"/bin/touch")))))) "/bin/touch"))))))
(test-equal "let-system" (test-equal "let-system"
(list `(begin ,(%current-system) #t) '(system-binding) '() (list `(begin ,(%current-system) #t) '(system-binding)
'low '() '()) 'low '() '())
(let* ((exp #~(begin (let* ((exp #~(begin
#$(let-system system system) #$(let-system system system)
@ -361,7 +360,6 @@
(string=? (gexp-input-output input) "out") (string=? (gexp-input-output input) "out")
'(system-binding))) '(system-binding)))
(x x)) (x x))
(gexp-native-inputs exp)
'low 'low
(lowered-gexp-inputs low) (lowered-gexp-inputs low)
(lowered-gexp-sources low)))) (lowered-gexp-sources low))))
@ -383,7 +381,6 @@
(test-equal "let-system, nested" (test-equal "let-system, nested"
(list `(system* ,(string-append "qemu-system-" (%current-system)) (list `(system* ,(string-append "qemu-system-" (%current-system))
"-m" "256") "-m" "256")
'()
'(system-binding)) '(system-binding))
(let ((exp #~(system* (let ((exp #~(system*
#+(let-system (system target) #+(let-system (system target)
@ -398,12 +395,12 @@
(basename command)) (basename command))
,@rest)) ,@rest))
(x x)) (x x))
(gexp-inputs exp) (match (gexp-inputs exp)
(match (gexp-native-inputs exp)
((input) ((input)
(and (eq? (struct-vtable (gexp-input-thing input)) (and (eq? (struct-vtable (gexp-input-thing input))
(@@ (guix gexp) <system-binding>)) (@@ (guix gexp) <system-binding>))
(string=? (gexp-input-output input) "out") (string=? (gexp-input-output input) "out")
(gexp-input-native? input)
'(system-binding))) '(system-binding)))
(x x))))) (x x)))))
@ -422,31 +419,26 @@
(bu (derivation->output-path (bu (derivation->output-path
(package-cross-derivation %store binutils target)))) (package-cross-derivation %store binutils target))))
(and (lset= equal? (and (lset= equal?
`((,%bootstrap-guile "out") (,glibc "out")) `((,%bootstrap-guile "out" #t)
(map gexp-input->tuple (gexp-native-inputs exp))) (,coreutils "out" #f)
(lset= equal? (,glibc "out" #t)
`((,coreutils "out") (,binutils "out")) (,binutils "out" #f))
(map gexp-input->tuple (gexp-inputs exp))) (map gexp-input->tuple (gexp-inputs exp)))
(equal? `(list ,guile ,cu ,libc ,bu) (equal? `(list ,guile ,cu ,libc ,bu)
(gexp->sexp* exp target))))) (gexp->sexp* exp target)))))
(test-equal "ungexp + ungexp-native, nested" (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))) (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils)))
(ungexp %bootstrap-guile))))) (ungexp %bootstrap-guile)))))
(list (map gexp-input->tuple (gexp-inputs exp)) (map gexp-input->tuple (gexp-inputs exp))))
'<>
(map gexp-input->tuple (gexp-native-inputs exp)))))
(test-equal "ungexp + ungexp-native, nested, special mixture" (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)))) (let* ((foo (gexp (foo (ungexp-native coreutils))))
(exp (gexp (bar (ungexp foo))))) (exp (gexp (bar (ungexp foo)))))
(list (map gexp-input->tuple (gexp-inputs exp)) (map gexp-input->tuple (gexp-inputs exp))))
'<>
(map gexp-input->tuple (gexp-native-inputs exp)))))
(test-assert "input list" (test-assert "input list"
(let ((exp (gexp (display (let ((exp (gexp (display
@ -456,7 +448,7 @@
(cu (derivation->output-path (cu (derivation->output-path
(package-derivation %store coreutils)))) (package-derivation %store coreutils))))
(and (lset= equal? (and (lset= equal?
`((,%bootstrap-guile "out") (,coreutils "out")) `((,%bootstrap-guile "out" #f) (,coreutils "out" #f))
(map gexp-input->tuple (gexp-inputs exp))) (map gexp-input->tuple (gexp-inputs exp)))
(equal? `(display '(,guile ,cu)) (equal? `(display '(,guile ,cu))
(gexp->sexp* exp))))) (gexp->sexp* exp)))))
@ -475,10 +467,8 @@
(xbu (derivation->output-path (xbu (derivation->output-path
(package-cross-derivation %store binutils target)))) (package-cross-derivation %store binutils target))))
(and (lset= equal? (and (lset= equal?
`((,%bootstrap-guile "out") (,coreutils "out")) `((,%bootstrap-guile "out" #t) (,coreutils "out" #t)
(map gexp-input->tuple (gexp-native-inputs exp))) (,glibc "out" #f) (,binutils "out" #f))
(lset= equal?
`((,glibc "out") (,binutils "out"))
(map gexp-input->tuple (gexp-inputs exp))) (map gexp-input->tuple (gexp-inputs exp)))
(equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
(gexp->sexp* exp target))))) (gexp->sexp* exp target)))))
@ -492,7 +482,7 @@
(package-derivation %store %bootstrap-guile)))) (package-derivation %store %bootstrap-guile))))
(exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
(and (lset= equal? (and (lset= equal?
`((,glibc "debug") (,%bootstrap-guile "out")) `((,glibc "debug" #f) (,%bootstrap-guile "out" #f))
(map gexp-input->tuple (gexp-inputs exp))) (map gexp-input->tuple (gexp-inputs exp)))
(equal? (gexp->sexp* exp) (equal? (gexp->sexp* exp)
`(list ,@(cons 5 outputs)))))) `(list ,@(cons 5 outputs))))))
@ -502,18 +492,16 @@
%bootstrap-guile)) %bootstrap-guile))
(exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
(and (lset= equal? (and (lset= equal?
`((,glibc "debug") (,%bootstrap-guile "out")) `((,glibc "debug" #t) (,%bootstrap-guile "out" #t))
(map gexp-input->tuple (gexp-native-inputs exp))) (map gexp-input->tuple (gexp-inputs exp)))
(null? (gexp-inputs exp))
(equal? (gexp->sexp* exp) ;native (equal? (gexp->sexp* exp) ;native
(gexp->sexp* exp "mips64el-linux"))))) (gexp->sexp* exp "mips64el-linux")))))
(test-assert "gexp list splicing + ungexp-splicing" (test-assert "gexp list splicing + ungexp-splicing"
(let* ((inner (gexp (ungexp-native glibc))) (let* ((inner (gexp (ungexp-native glibc)))
(exp (gexp (list (ungexp-splicing (list inner)))))) (exp (gexp (list (ungexp-splicing (list inner))))))
(and (equal? `((,glibc "out")) (and (equal? `((,glibc "out" #t))
(map gexp-input->tuple (gexp-native-inputs exp))) (map gexp-input->tuple (gexp-inputs exp)))
(null? (gexp-inputs exp))
(equal? (gexp->sexp* exp) ;native (equal? (gexp->sexp* exp) ;native
(gexp->sexp* exp "mips64el-linux"))))) (gexp->sexp* exp "mips64el-linux")))))