gexp: Optimize 'with-build-variables'.

* guix/gexp.scm (input-tuples->gexp, outputs->gexp): New procedures.
(with-build-variables): Use it.
This commit is contained in:
Ludovic Courtès 2021-02-28 18:22:11 +01:00
parent 789babb761
commit a76b6f8120
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5

View file

@ -1787,6 +1787,43 @@ (define* (load-path-expression modules #:optional (path %load-path)
extensions))
%load-compiled-path)))))))))
(define* (input-tuples->gexp inputs #:key native?)
"Given INPUTS, a list of label/gexp-input tuples, return a gexp that expands
to an input alist."
(define references
(map (match-lambda
((label input) input))
inputs))
(define labels
(match inputs
(((labels . _) ...)
labels)))
(define (proc . args)
(cons 'quote (list (map cons labels args))))
;; This gexp is more efficient than an equivalent hand-written gexp: fewer
;; allocations, no need to scan long list-valued <gexp-input> records in
;; search of file-like objects, etc.
(make-gexp references '() '() proc
(source-properties inputs)))
(define (outputs->gexp outputs)
"Given OUTPUTS, a list of output names, return a gexp that expands to an
output alist."
(define references
(map gexp-output outputs))
(define (proc . args)
`(list ,@(map (lambda (name)
`(cons ,name ((@ (guile) getenv) ,name)))
outputs)))
;; This gexp is more efficient than an equivalent hand-written gexp.
(make-gexp references '() '() proc
(source-properties outputs)))
(define (with-build-variables inputs outputs body)
"Return a gexp that surrounds BODY with a definition of the legacy
'%build-inputs', '%outputs', and '%output' variables based on INPUTS, a list
@ -1798,17 +1835,12 @@ (define (with-build-variables inputs outputs body)
;; expected.
(gexp (begin
(define %build-inputs
(map (lambda (tuple)
(apply cons tuple))
'(ungexp inputs)))
(ungexp (input-tuples->gexp inputs)))
(define %outputs
(list (ungexp-splicing
(map (lambda (name)
(gexp (cons (ungexp name)
(ungexp output name))))
outputs))))
(define %output
(ungexp (outputs->gexp outputs)))
(define %output
(assoc-ref %outputs "out"))
(ungexp body))))
(define* (gexp->script name exp