From bde7929bd06196ed84f96d08676ee43da4685975 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Mar 2015 21:44:01 +0100 Subject: gexp: Micro-optimize sexp serialization. * guix/gexp.scm (sexp->string): New procedure. (gexp->derivation): Use it instead of 'object->string'. --- guix/gexp.scm | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index 764c89a187..8dd824c512 100644 --- a/guix/gexp.scm +++ b/guix/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 ;;; Copyright © 2018 Clément Lassieur ;;; Copyright © 2018 Jan Nieuwenhuizen ;;; Copyright © 2019, 2020 Mathieu Othacehe @@ -941,6 +941,15 @@ second element is the derivation to compile them." modules system extensions guile deprecation-warnings module-path)) +(define (sexp->string sexp) + "Like 'object->string', but deterministic and slightly faster." + ;; Explicitly use UTF-8 for determinism, and also because UTF-8 output is + ;; faster. + (with-fluids ((%default-port-encoding "UTF-8")) + (call-with-output-string + (lambda (port) + (write sexp port))))) + (define* (lower-gexp exp #:key (module-path %load-path) @@ -1159,7 +1168,7 @@ The other arguments are as for 'derivation'." (return #f))) (guile -> (lowered-gexp-guile lowered)) (builder (text-file script-name - (object->string + (sexp->string (lowered-gexp-sexp lowered))))) (mbegin %store-monad (set-grafting graft?) ;restore the initial setting -- cgit v1.2.3 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(-) (limited to 'guix/gexp.scm') 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 @@ When TARGET is true, use it as the cross-compilation target triplet." (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 @@ 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 #: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 @@ The other arguments are as for 'derivation'." #: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 @@ references; otherwise, return only non-native references." 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 @@ #: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 @@ (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 @@ (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 @@ (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 @@ "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 @@ "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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ ;; (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 From 4fa9d48fd47df45372fddf2251c3fc0afd48fda0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 16 Feb 2021 21:46:18 +0100 Subject: 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(-) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index 8e80d4adbe..7a3228ec2e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1006,13 +1006,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)) @@ -1218,26 +1214,26 @@ The other arguments are as for 'derivation'." #:substitutable? substitutable? #:properties properties)))) -(define* (gexp-inputs exp #:key native?) - "Return the list of for EXP. When NATIVE? is true, return only -native references; otherwise, return only non-native references." +(define (gexp-inputs exp) + "Return the list of for EXP." + (define set-gexp-input-native? + (match-lambda + (($ thing output) + (%gexp-input thing output #t)))) + (define (add-reference-inputs ref result) (match ref (($ (? gexp? exp) _ #t) - (if native? - (append (gexp-inputs exp) - (gexp-inputs exp #:native? #t) - result) - result)) - (($ (? gexp? exp) _ #f) - (append (gexp-inputs exp #:native? native?) + (append (map set-gexp-input-native? (gexp-inputs exp)) result)) + (($ (? gexp? exp) _ #f) + (append (gexp-inputs exp) result)) (($ (? string? str)) (if (direct-store-path? str) (cons ref result) result)) (($ (? 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)) @@ -1261,9 +1257,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 f742c5db76..0bd1237316 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) )) (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"))))) -- cgit v1.2.3 From a26006ff72746a49dde6d548a8687bf55e9d4d3a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 17 Feb 2021 12:36:42 +0100 Subject: gexp: Keep 'lower-inputs' private. It had been made public in 6b6298ae39bfe185ce1ab18bb3d641ddfad17c8f but it's no longer needed since 779aa003fbacbbcb6973f289b607d1d285009cec. * guix/gexp.scm (lower-inputs): Do not export. --- guix/gexp.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index 7a3228ec2e..6990d33651 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -120,8 +120,6 @@ file-like? lower-object - lower-inputs - &gexp-error gexp-error? &gexp-input-error -- cgit v1.2.3 From b57de6fea126f907a873ae14ad8b32dc32456e8e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 17 Feb 2021 14:25:43 +0100 Subject: gexp: Micro-optimize 'gexp->sexp' and 'lower-inputs'. * guix/gexp.scm (lower-inputs, gexp->sexp): Change keyword parameters to positional parameters. Adjust callers accordingly. * tests/gexp.scm (gexp->sexp*, "gexp->file"): Adjust accordingly. --- guix/gexp.scm | 20 ++++++-------------- tests/gexp.scm | 5 ++--- 2 files changed, 8 insertions(+), 17 deletions(-) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index 6990d33651..943b336539 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -826,8 +826,7 @@ list." (one-of symbol? string? keyword? pair? null? array? number? boolean? char?))) -(define* (lower-inputs inputs - #:key system target) +(define (lower-inputs inputs system target) "Turn any object from INPUTS into a derivation input for SYSTEM or a store item (a \"source\"); return the corresponding input list as a monadic value. When TARGET is true, use it as the cross-compilation target triplet." @@ -874,8 +873,7 @@ corresponding or store item." (match graphs (((file-names . inputs) ...) (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs) - #:system system - #:target target))) + system target))) (return (map cons file-names inputs)))))) (define* (lower-references lst #:key system target) @@ -1005,11 +1003,8 @@ derivations--e.g., code evaluated for its side effects." (return guile-for-build) (default-guile-derivation system))) (inputs (lower-inputs (gexp-inputs exp) - #:system system - #:target target)) - (sexp (gexp->sexp exp - #:system system - #:target target)) + system target)) + (sexp (gexp->sexp exp system target)) (extensions -> (gexp-extensions exp)) (exts (mapm %store-monad (lambda (obj) @@ -1278,9 +1273,7 @@ The other arguments are as for 'derivation'." (delete-duplicates (add-reference-output (gexp-references exp) '()))) -(define* (gexp->sexp exp #:key - (system (%current-system)) - (target (%current-target-system))) +(define (gexp->sexp exp system target) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" (define* (reference->sexp ref #:optional native?) @@ -1293,8 +1286,7 @@ and in the current monad setting (system type, etc.)" (return `((@ (guile) getenv) ,output))) (($ (? gexp? exp) output n?) (gexp->sexp exp - #:system system - #:target (if (or n? native?) #f target))) + system (if (or n? native?) #f target))) (($ (refs ...) output n?) (mapm %store-monad (lambda (ref) diff --git a/tests/gexp.scm b/tests/gexp.scm index 0bd1237316..a30d0ff6b4 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -57,8 +57,7 @@ (apply (@@ (guix gexp) gexp->sexp) x)) (define* (gexp->sexp* exp #:optional target) - (run-with-store %store (gexp->sexp exp - #:target target) + (run-with-store %store (gexp->sexp exp (%current-system) target) #:guile-for-build (%guile-for-build))) (define (gexp-input->tuple input) @@ -540,7 +539,7 @@ (test-assertm "gexp->file" (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile)))) (guile (package-file %bootstrap-guile)) - (sexp (gexp->sexp exp)) + (sexp (gexp->sexp exp (%current-system) #f)) (drv (gexp->file "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) -- cgit v1.2.3 From c8bd5fa59c4493734fa41f6c4d5b972ba8b5b141 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 19 Feb 2021 10:18:48 +0100 Subject: gexp: Reduce allocations while traversing lists. This reduces the total amount of memory allocated by 8% when running "guix build qemu -d --no-grafts". * guix/gexp.scm (fold/tree): New procedure. (gexp-inputs)[interesting?]: New procedure. [add-reference-inputs]: Change (lst ...) clause to (? pair? lst), and use 'fold/tree' to recurse into it. (gexp-inputs)[add-reference-output]: Likewise, and remove plain (lst ...) clause. Call 'fold'. (gexp->sexp)[reference->sexp]: In the list case, avoid boxing and recursive call when the object has a plain non-aggregate type. --- guix/gexp.scm | 76 ++++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 49 insertions(+), 27 deletions(-) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index 943b336539..cad57f62ca 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1207,6 +1207,16 @@ The other arguments are as for 'derivation'." #:substitutable? substitutable? #:properties properties)))) +(define (fold/tree proc seed lst) + "Like 'fold', but recurse into sub-lists of LST and accept improper lists." + (let loop ((obj lst) + (result seed)) + (match obj + ((head . tail) + (loop tail (loop head result))) + (_ + (proc obj result))))) + (define (gexp-inputs exp) "Return the list of for EXP." (define set-gexp-input-native? @@ -1214,6 +1224,10 @@ The other arguments are as for 'derivation'." (($ thing output) (%gexp-input thing output #t)))) + (define (interesting? obj) + (or (file-like? obj) + (and (string? obj) (direct-store-path? obj)))) + (define (add-reference-inputs ref result) (match ref (($ (? gexp? exp) _ #t) @@ -1230,18 +1244,23 @@ The other arguments are as for 'derivation'." ;; THING is a derivation, or a package, or an origin, etc. (cons ref result) result)) - (($ (lst ...) output n?) - (fold-right add-reference-inputs result - ;; XXX: For now, automatically convert LST to a list of - ;; gexp-inputs. Inherit N?. - (map (match-lambda - ((? gexp-input? x) - (%gexp-input (gexp-input-thing x) - (gexp-input-output x) - n?)) - (x - (%gexp-input x "out" n?))) - lst))) + (($ (? pair? lst) output n?) + ;; XXX: Scan LST for inputs. Inherit N?. + (fold/tree (lambda (obj result) + (match obj + ((? gexp-input? x) + (cons (%gexp-input (gexp-input-thing x) + (gexp-input-output x) + n?) + result)) + ((? interesting? x) + (cons (%gexp-input x "out" n?) result)) + ((? gexp? x) + (append (gexp-inputs x) result)) + (_ + result))) + result + lst)) (_ ;; Ignore references to other kinds of objects. result))) @@ -1258,20 +1277,20 @@ The other arguments are as for 'derivation'." (cons name result)) (($ (? gexp? exp)) (append (gexp-outputs exp) result)) - (($ (lst ...) output native?) - ;; XXX: Automatically convert LST. - (add-reference-output (map (match-lambda - ((? gexp-input? x) x) - (x (%gexp-input x "out" native?))) - lst) - result)) - ((lst ...) - (fold-right add-reference-output result lst)) + (($ (? pair? lst)) + ;; XXX: Scan LST for outputs. + (fold/tree (lambda (obj result) + (match obj + (($ name) (cons name result)) + ((? gexp? x) (append (gexp-outputs x) result)) + (_ result))) + result + lst)) (_ result))) (delete-duplicates - (add-reference-output (gexp-references exp) '()))) + (fold add-reference-output '() (gexp-references exp)))) (define (gexp->sexp exp system target) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, @@ -1291,11 +1310,14 @@ and in the current monad setting (system type, etc.)" (mapm %store-monad (lambda (ref) ;; XXX: Automatically convert REF to an gexp-input. - (reference->sexp - (if (gexp-input? ref) - ref - (%gexp-input ref "out" n?)) - (or n? native?))) + (if (or (symbol? ref) (number? ref) + (boolean? ref) (null? ref) (array? ref)) + (return ref) + (reference->sexp + (if (gexp-input? ref) + ref + (%gexp-input ref "out" n?)) + (or n? native?)))) refs)) (($ (? struct? thing) output n?) (let ((target (if (or n? native?) #f target))) -- cgit v1.2.3 From fcde4e10b87db9a71dbc115af548aeabe9068310 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 23 Feb 2021 14:19:48 +0100 Subject: gexp: Reduce allocations in 'gexp-attribute'. * guix/gexp.scm (gexp-attribute): Use 'fold' and 'fold/tree' instead of 'append-map'. --- guix/gexp.scm | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index cad57f62ca..8cd44ba534 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -757,19 +757,28 @@ attribute that is traversed." (append (let ((attribute (self-attribute gexp))) (validate gexp attribute) attribute) - (append-map (match-lambda - (($ (? gexp? exp)) - (gexp-attribute exp self-attribute - #:validate validate)) - (($ (lst ...)) - (append-map (lambda (item) - (gexp-attribute item self-attribute - #:validate - validate)) - lst)) - (_ - '())) - (gexp-references gexp))) + (reverse + (fold (lambda (input result) + (match input + (($ (? gexp? exp)) + (append (gexp-attribute exp self-attribute + #:validate validate) + result)) + (($ (lst ...)) + (fold/tree (lambda (obj result) + (match obj + ((? gexp? exp) + (append (gexp-attribute exp self-attribute + #:validate validate) + result)) + (_ + result))) + result + lst)) + (_ + result))) + '() + (gexp-references gexp)))) equal?) '())) ;plain Scheme data type -- cgit v1.2.3 From 9fc4e94986e68e0e33b260e2389765e2d3b7dd07 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 Mar 2021 12:27:18 +0100 Subject: gexp: #:references-graphs refers to non-native derivations. Fixes a regression introduced in c6d6aee6659acb293eb33f498fdac3b47a19a48, where #:reference-graphs would end up referring to native inputs. This would notably break the compilation of systems using a childhurd, because they would attempt to build the 'hurd' package natively. * guix/gexp.scm (lower-reference-graphs)[tuple->gexp-input]: Honor TARGET. * tests/gexp.scm ("gexp->derivation #:references-graphs cross-compilation"): New test. --- guix/gexp.scm | 4 ++-- tests/gexp.scm | 16 ++++++++++++++++ 2 files changed, 18 insertions(+), 2 deletions(-) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index 8cd44ba534..b72b8f4061 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -875,9 +875,9 @@ corresponding or store item." (define tuple->gexp-input (match-lambda ((thing) - (%gexp-input thing "out" #t)) + (%gexp-input thing "out" (not target))) ((thing output) - (%gexp-input thing output #t)))) + (%gexp-input thing output (not target))))) (match graphs (((file-names . inputs) ...) diff --git a/tests/gexp.scm b/tests/gexp.scm index a30d0ff6b4..834e78b9a0 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1095,6 +1095,22 @@ importing.* \\(guix config\\) from the host" (call-with-input-file g-guile read) (list (derivation->output-path guile-drv) bash)))))) +(test-assertm "gexp->derivation #:references-graphs cross-compilation" + ;; The objects passed in #:references-graphs implicitly refer to + ;; cross-compiled derivations. Make sure this is the case. + (mlet* %store-monad ((drv1 (lower-object coreutils (%current-system) + #:target "i586-pc-gnu")) + (drv2 (lower-object coreutils (%current-system) + #:target #f)) + (drv3 (gexp->derivation "three" + #~(symlink #$coreutils #$output) + #:target "i586-pc-gnu" + #:references-graphs + `(("coreutils" ,coreutils)))) + (refs (references* (derivation-file-name drv3)))) + (return (and (member (derivation-file-name drv1) refs) + (not (member (derivation-file-name drv2) refs)))))) + (test-assertm "gexp->derivation #:allowed-references" (mlet %store-monad ((drv (gexp->derivation "allowed-refs" #~(begin -- cgit v1.2.3 From 6de3ef0d5e74e18e82292617c424cf30f932e699 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 5 Mar 2021 09:29:24 +0100 Subject: gexp: Honor #:target in 'compiled-modules'. * guix/gexp.scm (compiled-modules): Pass #:target to 'gexp->derivation'. --- guix/gexp.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix/gexp.scm') diff --git a/guix/gexp.scm b/guix/gexp.scm index b72b8f4061..b9a2483773 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1708,6 +1708,7 @@ TARGET, a GNU triplet." ;; TODO: Pass MODULES as an environment variable. (gexp->derivation name build #:system system + #:target target #:guile-for-build guile #:local-build? #t #:env-vars -- cgit v1.2.3