civodul pushed a commit to branch wip-build-systems-gexp in repository guix.
commit e4daae185f16ddcb740860e139e1916795c54ffb Author: Ludovic Courtès <[email protected]> Date: Fri May 13 15:39:02 2016 +0200 DRAFT gexp: Handle list conversion to <gexp-input> in the expanded code. This reduces the number of recursive calls to 'add-reference-inputs' and 'add-reference-output' when 'gexp-inputs' and 'gexp-outputs' is called. * guix/gexp.scm (gexp-inputs)[add-reference-inputs]: Don't iterate on the list. (gexp-outputs)[add-reference-output]: Likewise. (gexp-modules)[reference-modules]: New procedure. Use it as first argument to 'append-map'. (gexp->sexp)[reference->sexp]: Likewise. (ensure-input-list): New procedure. (gexp)[escape->ref]: Have the emitted code use it. (imported-files)[build]: Split FILES in two different lists, and use 'ungexp-native-splicing' instead of 'ungexp-native' for the second one. (with-build-variables): Likewise. * tests/gexp.scm ("input list", "input list + ungexp-native"): Explicitly use 'gexp-input'. * guix/packages.scm (patch-and-repack)[build]: For PATCHES, use ungexp-native-splicing instead of ungexp-native. --- guix/gexp.scm | 71 ++++++++++++++++++++++++++----------------------------- guix/packages.scm | 2 +- tests/gexp.scm | 10 +++++--- 3 files changed, 41 insertions(+), 42 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index c91c81d..d30769e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -468,20 +468,19 @@ whether this should be considered a \"native\" input or not." (define (gexp-modules gexp) "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty list." + (define reference-modules + (match-lambda + (($ <gexp-input> (? gexp? exp)) + (gexp-modules exp)) + (($ <gexp-input> (lst ...)) + (append-map reference-modules lst)) + (_ + '()))) + (if (gexp? gexp) (delete-duplicates (append (gexp-self-modules gexp) - (append-map (match-lambda - (($ <gexp-input> (? gexp? exp)) - (gexp-modules exp)) - (($ <gexp-input> (lst ...)) - (append-map (lambda (item) - (if (gexp? item) - (gexp-modules item) - '())) - lst)) - (_ - '())) + (append-map reference-modules (gexp-references gexp)))) '())) ;plain Scheme data type @@ -723,13 +722,7 @@ references; otherwise, return only non-native references." result)) (($ <gexp-input> (lst ...) output n?) (if (eqv? native? n?) - (fold-right add-reference-inputs result - ;; XXX: For now, automatically convert LST to a list of - ;; gexp-inputs. - (map (match-lambda - ((? gexp-input? x) x) - (x (%gexp-input x "out" (or n? native?)))) - lst)) + (fold-right add-reference-inputs result lst) result)) (_ ;; Ignore references to other kinds of objects. @@ -751,12 +744,7 @@ references; otherwise, return only non-native references." (($ <gexp-input> (? gexp? exp)) (append (gexp-outputs exp) result)) (($ <gexp-input> (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)) + (add-reference-output lst result)) ((lst ...) (fold-right add-reference-output result lst)) (_ @@ -785,12 +773,7 @@ and in the current monad setting (system type, etc.)" (($ <gexp-input> (refs ...) output n?) (sequence %store-monad (map (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?))) + (reference->sexp ref (or n? native?))) refs))) (($ <gexp-input> (? struct? thing) output n?) (let ((target (if (or n? native?) #f target)) @@ -833,6 +816,17 @@ environment." (identifier-syntax modules))) body ...)) +(define (ensure-input-list lst native?) + "Make sure LST is a list of <gexp-input> objects. If LST is not a list (for +instance, it could be a gexp), return it." + (if (pair? lst) + (map (lambda (x) + (if (gexp-input? x) + x + (%gexp-input x "out" native?))) + lst) + lst)) + (define-syntax gexp (lambda (s) (define (collect-escapes exp) @@ -873,13 +867,15 @@ environment." ((ungexp drv-or-pkg out) #'(%gexp-input drv-or-pkg out #f)) ((ungexp-splicing lst) - #'(%gexp-input lst "out" #f)) + #'(%gexp-input (ensure-input-list lst #f) + "out" #f)) ((ungexp-native thing) #'(%gexp-input thing "out" #t)) ((ungexp-native drv-or-pkg out) #'(%gexp-input drv-or-pkg out #t)) ((ungexp-native-splicing lst) - #'(%gexp-input lst "out" #t)))) + #'(%gexp-input (ensure-input-list lst #t) + "out" #t)))) (define (substitute-ungexp exp substs) ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with @@ -969,14 +965,13 @@ as returned by 'local-file' for example." (gexp (begin (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' - (use-modules (ice-9 match)) (mkdir (ungexp output)) (chdir (ungexp output)) - (for-each (match-lambda - ((final-path store-path) + (for-each (lambda (final-path store-path) (mkdir-p (dirname final-path)) - (symlink store-path final-path))) - '(ungexp files))))) + (symlink store-path final-path)) + '(ungexp (map first files)) + '((ungexp-native-splicing (map second files))))))) ;; TODO: Pass FILES as an environment variable so that BUILD remains ;; exactly the same regardless of FILES: less disk space, and fewer @@ -1108,7 +1103,7 @@ of name/gexp-input tuples, and OUTPUTS, a list of strings." (define %build-inputs (map (lambda (tuple) (apply cons tuple)) - '(ungexp inputs))) + '((ungexp-splicing inputs)))) (define %outputs (list (ungexp-splicing (map (lambda (name) diff --git a/guix/packages.scm b/guix/packages.scm index dc0ae0b..4f92ef2 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -553,7 +553,7 @@ specifies modules in scope when evaluating SNIPPET." "source is under '~a'~%" directory) (chdir directory) - (and (every apply-patch '#+patches) + (and (every apply-patch '(#+@patches)) #+@(if snippet #~((let ((module (make-fresh-user-module))) (module-use-interfaces! diff --git a/tests/gexp.scm b/tests/gexp.scm index 6ceb35e..2f42222 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -292,7 +292,8 @@ (test-assert "input list" (let ((exp (gexp (display - '(ungexp (list %bootstrap-guile coreutils))))) + '(ungexp (list (gexp-input %bootstrap-guile) + (gexp-input coreutils)))))) (guile (derivation->output-path (package-derivation %store %bootstrap-guile))) (cu (derivation->output-path @@ -306,8 +307,11 @@ (test-assert "input list + ungexp-native" (let* ((target "mips64el-linux") (exp (gexp (display - (cons '(ungexp-native (list %bootstrap-guile coreutils)) - '(ungexp (list glibc binutils)))))) + (cons '(ungexp-native (map gexp-input + (list %bootstrap-guile + coreutils))) + '(ungexp (map gexp-input + (list glibc binutils))))))) (guile (derivation->output-path (package-derivation %store %bootstrap-guile))) (cu (derivation->output-path
