From fc6d6aee6659acb293eb33f498fdac3b47a19a48 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Feb 2021 20:54:27 +0100 Subject: gexp: 'gexp-inputs' returns a list of records. This slightly reduces memory allocation. * guix/gexp.scm (lower-inputs): Expect a list of rather than a list of tuples. (lower-reference-graphs)[tuple->gexp-input]: New procedure. Use it. (gexp-inputs): Return a list of 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 8dd824c512..8e80d4adbe 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -842,24 +842,23 @@ (define filterm (with-monad %store-monad (>>= (mapm/accumulate-builds (match-lambda - (((? struct? thing) sub-drv ...) - (mlet %store-monad ((obj (lower-object - thing system #:target target))) + (($ (? store-item? item)) + (return item)) + (($ 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 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 @@ (define* (lower-reference-graphs graphs #:key system target) "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 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 @@ (define (add-modules exp modules) #: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 records instead of tuples. + "Return the list of 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? exp) _ #t) @@ -1229,12 +1234,12 @@ (define (add-reference-inputs ref result) result)) (($ (? string? str)) (if (direct-store-path? str) - (cons `(,str) result) + (cons ref result) result)) (($ (? 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)) (($ (lst ...) output n?) (fold-right add-reference-inputs result diff --git a/tests/gexp.scm b/tests/gexp.scm index 6e92f0e4b3..f742c5db76 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,6 +63,9 @@ (define* (gexp->sexp* exp #:optional target) #: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 @@ (define defmod 'define-module) ;fool Geiser (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 @@ (define defmod 'define-module) ;fool Geiser (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 @@ (define defmod 'define-module) ;fool Geiser (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 @@ (define defmod 'define-module) ;fool Geiser "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 @@ (define defmod 'define-module) ;fool Geiser "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 @@ (define defmod 'define-module) ;fool Geiser (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 @@ (define defmod 'define-module) ;fool Geiser (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 @@ (define defmod 'define-module) ;fool Geiser (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 @@ (define (match-input thing) (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 @@ (define (match-input thing) (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 @@ (define (match-input thing) (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 @@ (define (match-input thing) (low (run-with-store %store (lower-gexp exp)))) (list (lowered-gexp-sexp low) (match (gexp-inputs exp) - (((($ (@@ (guix gexp) )) "out")) - '(system-binding)) + ((input) + (and (eq? (struct-vtable (gexp-input-thing input)) + (@@ (guix gexp) )) + (string=? (gexp-input-output input) "out") + '(system-binding))) (x x)) (gexp-native-inputs exp) 'low @@ -388,8 +400,11 @@ (define (match-input thing) (x x)) (gexp-inputs exp) (match (gexp-native-inputs exp) - (((($ (@@ (guix gexp) )) "out")) - '(system-binding)) + ((input) + (and (eq? (struct-vtable (gexp-input-thing input)) + (@@ (guix gexp) )) + (string=? (gexp-input-output input) "out") + '(system-binding))) (x x))))) (test-assert "ungexp + ungexp-native" @@ -408,10 +423,10 @@ (define (match-input thing) (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 @@ (define (match-input thing) (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 @@ (define (match-input thing) ;; (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 @@ (define (match-input thing) (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 @@ (define (match-input thing) (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 @@ (define (match-input thing) (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 @@ (define (match-input thing) (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 @@ (define (match-input thing) (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"))))) -- cgit v1.2.3