summaryrefslogtreecommitdiff
path: root/guix/gexp.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-02-19 10:18:48 +0100
committerLudovic Courtès <ludo@gnu.org>2021-02-23 15:24:49 +0100
commitc8bd5fa59c4493734fa41f6c4d5b972ba8b5b141 (patch)
treeaaafa3e75f1af054b8428646ef57d574942bcf1e /guix/gexp.scm
parentb57de6fea126f907a873ae14ad8b32dc32456e8e (diff)
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.
Diffstat (limited to 'guix/gexp.scm')
-rw-r--r--guix/gexp.scm76
1 files changed, 49 insertions, 27 deletions
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 <gexp-input> for EXP."
(define set-gexp-input-native?
@@ -1214,6 +1224,10 @@ The other arguments are as for 'derivation'."
(($ <gexp-input> 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-input> (? 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))
- (($ <gexp-input> (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)))
+ (($ <gexp-input> (? 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-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))
- ((lst ...)
- (fold-right add-reference-output result lst))
+ (($ <gexp-input> (? pair? lst))
+ ;; XXX: Scan LST for outputs.
+ (fold/tree (lambda (obj result)
+ (match obj
+ (($ <gexp-output> 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))
(($ <gexp-input> (? struct? thing) output n?)
(let ((target (if (or n? native?) #f target)))