me/guix
Archived
1
0
Fork 0
Code Activity

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

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2021-02-16 20:54:27 +01:00
parent bde7929bd0
commit fc6d6aee66
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 79 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
guix/gexp.scm
View file

@ -842,24 +842,23 @@ When TARGET is true, use it as the cross-compilation target triplet."
(with-monad %store-monad (with-monad %store-monad
(>>= (mapm/accumulate-builds (>>= (mapm/accumulate-builds
(match-lambda (match-lambda
(((? struct? thing) sub-drv ...) (($ <gexp-input> (? store-item? item))
(mlet %store-monad ((obj (lower-object (return item))
thing system #:target target))) (($ <gexp-input> thing output native?)
(mlet %store-monad ((obj (lower-object thing system
#:target
(and (not native?)
target))))
(return (match obj (return (match obj
((? derivation? drv) ((? derivation? drv)
(let ((outputs (if (null? sub-drv) (derivation-input drv (list output)))
'("out")
sub-drv)))
(derivation-input drv outputs)))
((? store-item? item) ((? store-item? item)
item) item)
((? self-quoting?) ((? self-quoting?)
;; Some inputs such as <system-binding> can lower to ;; Some inputs such as <system-binding> can lower to
;; a self-quoting object that FILTERM will filter ;; a self-quoting object that FILTERM will filter
;; out. ;; out.
#f))))) #f))))))
(((? store-item? item))
(return item)))
inputs) inputs)
filterm))) 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 "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 #:reference-graphs argument, lower it such that each INPUT is replaced by the
corresponding <derivation-input> or store item." 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 (match graphs
(((file-names . inputs) ...) (((file-names . inputs) ...)
(mlet %store-monad ((inputs (lower-inputs inputs (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs)
#:system system #:system system
#:target target))) #:target target)))
(return (map cons file-names inputs)))))) (return (map cons file-names inputs))))))
@ -1213,9 +1219,8 @@ The other arguments are as for 'derivation'."
#:properties properties)))) #:properties properties))))
(define* (gexp-inputs exp #:key native?) (define* (gexp-inputs exp #:key native?)
"Return the input list for EXP. When NATIVE? is true, return only native "Return the list of <gexp-input> for EXP. When NATIVE? is true, return only
references; otherwise, return only non-native references." native references; otherwise, return only non-native references."
;; TODO: Return <gexp-input> records instead of tuples.
(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)
@ -1229,12 +1234,12 @@ references; otherwise, return only non-native references."
result)) result))
(($ <gexp-input> (? string? str)) (($ <gexp-input> (? string? str))
(if (direct-store-path? str) (if (direct-store-path? str)
(cons `(,str) 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 (and (eqv? n? native?) (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 `(,thing ,output) result) (cons ref result)
result)) result))
(($ <gexp-input> (lst ...) output n?) (($ <gexp-input> (lst ...) output n?)
(fold-right add-reference-inputs result (fold-right add-reference-inputs result

96
tests/gexp.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -63,6 +63,9 @@
#:target target) #:target target)
#:guile-for-build (%guile-for-build))) #:guile-for-build (%guile-for-build)))
(define (gexp-input->tuple input)
(list (gexp-input-thing input) (gexp-input-output 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'.
(dummy-package "extension" (dummy-package "extension"
@ -106,8 +109,8 @@
(let ((exp (gexp (display (ungexp coreutils))))) (let ((exp (gexp (display (ungexp coreutils)))))
(and (gexp? exp) (and (gexp? exp)
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((p "out")) ((input)
(eq? p coreutils))) (eq? (gexp-input-thing input) coreutils)))
(equal? `(display ,(derivation->output-path (equal? `(display ,(derivation->output-path
(package-derivation %store coreutils))) (package-derivation %store coreutils)))
(gexp->sexp* exp))))) (gexp->sexp* exp)))))
@ -116,8 +119,8 @@
(let ((exp (gexp (coreutils . (ungexp coreutils))))) (let ((exp (gexp (coreutils . (ungexp coreutils)))))
(and (gexp? exp) (and (gexp? exp)
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((p "out")) ((input)
(eq? p coreutils))) (eq? (gexp-input-thing input) coreutils)))
(equal? `(coreutils . ,(derivation->output-path (equal? `(coreutils . ,(derivation->output-path
(package-derivation %store coreutils))) (package-derivation %store coreutils)))
(gexp->sexp* exp))))) (gexp->sexp* exp)))))
@ -126,8 +129,9 @@
(let ((exp (gexp (display (ungexp (package-source coreutils)))))) (let ((exp (gexp (display (ungexp (package-source coreutils))))))
(and (gexp? exp) (and (gexp? exp)
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((o "out")) ((input)
(eq? o (package-source coreutils)))) (and (eq? (gexp-input-thing input) (package-source coreutils))
(string=? (gexp-input-output input) "out"))))
(equal? `(display ,(derivation->output-path (equal? `(display ,(derivation->output-path
(package-source-derivation (package-source-derivation
%store (package-source coreutils)))) %store (package-source coreutils))))
@ -141,8 +145,9 @@
"sha256" file))) "sha256" file)))
(and (gexp? exp) (and (gexp? exp)
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((x "out")) ((input)
(eq? x local))) (and (eq? (gexp-input-thing input) local)
(string=? (gexp-input-output input) "out"))))
(equal? `(display ,intd) (gexp->sexp* exp))))) (equal? `(display ,intd) (gexp->sexp* exp)))))
(test-assert "one local file, symlink" (test-assert "one local file, symlink"
@ -158,8 +163,9 @@
"sha256" file))) "sha256" file)))
(and (gexp? exp) (and (gexp? exp)
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((x "out")) ((input)
(eq? x local))) (and (eq? (gexp-input-thing input) local)
(string=? (gexp-input-output input) "out"))))
(equal? `(display ,intd) (gexp->sexp* exp))))) (equal? `(display ,intd) (gexp->sexp* exp)))))
(lambda () (lambda ()
(false-if-exception (delete-file link)))))) (false-if-exception (delete-file link))))))
@ -201,8 +207,9 @@
(expected (add-text-to-store %store "hi" "Hello, world!"))) (expected (add-text-to-store %store "hi" "Hello, world!")))
(and (gexp? exp) (and (gexp? exp)
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((x "out")) ((input)
(eq? x file))) (and (eq? (gexp-input-thing input) file)
(string=? (gexp-input-output input) "out"))))
(equal? `(display ,expected) (gexp->sexp* exp))))) (equal? `(display ,expected) (gexp->sexp* exp)))))
(test-assert "same input twice" (test-assert "same input twice"
@ -211,8 +218,9 @@
(display (ungexp coreutils)))))) (display (ungexp coreutils))))))
(and (gexp? exp) (and (gexp? exp)
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((p "out")) ((input)
(eq? p coreutils))) (and (eq? (gexp-input-thing input) coreutils)
(string=? (gexp-input-output input) "out"))))
(let ((e `(display ,(derivation->output-path (let ((e `(display ,(derivation->output-path
(package-derivation %store coreutils))))) (package-derivation %store coreutils)))))
(equal? `(begin ,e ,e) (gexp->sexp* exp)))))) (equal? `(begin ,e ,e) (gexp->sexp* exp))))))
@ -228,9 +236,8 @@
(display (ungexp drv)) (display (ungexp drv))
(display (ungexp txt)))))) (display (ungexp txt))))))
(define (match-input thing) (define (match-input thing)
(match-lambda (lambda (input)
((drv-or-pkg _ ...) (eq? (gexp-input-thing input) thing)))
(eq? thing drv-or-pkg))))
(and (gexp? exp) (and (gexp? exp)
(= 4 (length (gexp-inputs exp))) (= 4 (length (gexp-inputs exp)))
@ -255,8 +262,9 @@
(string-append (derivation->output-path drv) (string-append (derivation->output-path drv)
"/bin/guile")))) "/bin/guile"))))
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((thing "out")) ((input)
(eq? thing fa)))))) (and (eq? (gexp-input-thing input) fa)
(string=? (gexp-input-output input) "out")))))))
(test-assert "file-append, output" (test-assert "file-append, output"
(let* ((drv (package-derivation %store glibc)) (let* ((drv (package-derivation %store glibc))
@ -268,8 +276,9 @@
(string-append (derivation->output-path drv "debug") (string-append (derivation->output-path drv "debug")
"/lib/debug")))) "/lib/debug"))))
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((thing "debug")) ((input)
(eq? thing fa)))))) (and (eq? (gexp-input-thing input) fa)
(string=? (gexp-input-output input) "debug")))))))
(test-assert "file-append, nested" (test-assert "file-append, nested"
(let* ((drv (package-derivation %store glibc)) (let* ((drv (package-derivation %store glibc))
@ -283,8 +292,8 @@
(string-append (derivation->output-path drv) (string-append (derivation->output-path drv)
"/bin/getent")))) "/bin/getent"))))
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((thing "out")) ((input)
(eq? thing file)))))) (eq? (gexp-input-thing input) file))))))
(test-assert "file-append, raw store item" (test-assert "file-append, raw store item"
(let* ((obj (plain-file "example.txt" "Hello!")) (let* ((obj (plain-file "example.txt" "Hello!"))
@ -346,8 +355,11 @@
(low (run-with-store %store (lower-gexp exp)))) (low (run-with-store %store (lower-gexp exp))))
(list (lowered-gexp-sexp low) (list (lowered-gexp-sexp low)
(match (gexp-inputs exp) (match (gexp-inputs exp)
(((($ (@@ (guix gexp) <system-binding>)) "out")) ((input)
'(system-binding)) (and (eq? (struct-vtable (gexp-input-thing input))
(@@ (guix gexp) <system-binding>))
(string=? (gexp-input-output input) "out")
'(system-binding)))
(x x)) (x x))
(gexp-native-inputs exp) (gexp-native-inputs exp)
'low 'low
@ -388,8 +400,11 @@
(x x)) (x x))
(gexp-inputs exp) (gexp-inputs exp)
(match (gexp-native-inputs exp) (match (gexp-native-inputs exp)
(((($ (@@ (guix gexp) <system-binding>)) "out")) ((input)
'(system-binding)) (and (eq? (struct-vtable (gexp-input-thing input))
(@@ (guix gexp) <system-binding>))
(string=? (gexp-input-output input) "out")
'(system-binding)))
(x x))))) (x x)))))
(test-assert "ungexp + ungexp-native" (test-assert "ungexp + ungexp-native"
@ -408,10 +423,10 @@
(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") (,glibc "out"))
(gexp-native-inputs exp)) (map gexp-input->tuple (gexp-native-inputs exp)))
(lset= equal? (lset= equal?
`((,coreutils "out") (,binutils "out")) `((,coreutils "out") (,binutils "out"))
(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)))))
@ -419,7 +434,9 @@
(list `((,%bootstrap-guile "out")) '<> `((,coreutils "out"))) (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out")))
(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 (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" (test-equal "ungexp + ungexp-native, nested, special mixture"
`(() <> ((,coreutils "out"))) `(() <> ((,coreutils "out")))
@ -427,7 +444,9 @@
;; (gexp-native-inputs exp) used to return '(), wrongfully. ;; (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 (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" (test-assert "input list"
(let ((exp (gexp (display (let ((exp (gexp (display
@ -438,7 +457,7 @@
(package-derivation %store coreutils)))) (package-derivation %store coreutils))))
(and (lset= equal? (and (lset= equal?
`((,%bootstrap-guile "out") (,coreutils "out")) `((,%bootstrap-guile "out") (,coreutils "out"))
(gexp-inputs exp)) (map gexp-input->tuple (gexp-inputs exp)))
(equal? `(display '(,guile ,cu)) (equal? `(display '(,guile ,cu))
(gexp->sexp* exp))))) (gexp->sexp* exp)))))
@ -457,10 +476,10 @@
(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") (,coreutils "out"))
(gexp-native-inputs exp)) (map gexp-input->tuple (gexp-native-inputs exp)))
(lset= equal? (lset= equal?
`((,glibc "out") (,binutils "out")) `((,glibc "out") (,binutils "out"))
(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)))))
@ -474,7 +493,7 @@
(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") (,%bootstrap-guile "out"))
(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))))))
@ -484,7 +503,7 @@
(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") (,%bootstrap-guile "out"))
(gexp-native-inputs exp)) (map gexp-input->tuple (gexp-native-inputs exp)))
(null? (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")))))
@ -492,7 +511,8 @@
(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")) (gexp-native-inputs exp)) (and (equal? `((,glibc "out"))
(map gexp-input->tuple (gexp-native-inputs exp)))
(null? (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")))))