[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
12/15: gexp: Reduce allocations while traversing lists.
From: |
guix-commits |
Subject: |
12/15: gexp: Reduce allocations while traversing lists. |
Date: |
Tue, 23 Feb 2021 08:34:03 -0500 (EST) |
civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.
commit 1976051b444e54c3cc82ac395687d9dae3b79e81
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Feb 19 10:18:48 2021 +0100
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(-)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 20f0c34..8f49a0b 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1209,6 +1209,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?
@@ -1216,6 +1226,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)
@@ -1232,18 +1246,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)))
@@ -1260,20 +1279,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,
@@ -1293,11 +1312,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)))
- 09/15: gexp: Keep 'lower-inputs' private., (continued)
- 09/15: gexp: Keep 'lower-inputs' private., guix-commits, 2021/02/23
- 06/15: squash! build-system: Rewrite using gexps., guix-commits, 2021/02/23
- 11/15: store: Object cache profiling shows the number of entries., guix-commits, 2021/02/23
- 10/15: gexp: Micro-optimize 'gexp->sexp' and 'lower-inputs'., guix-commits, 2021/02/23
- 08/15: gexp: 'gexp-inputs' returns both native and non-native inputs., guix-commits, 2021/02/23
- 14/15: store: Micro-optimize object cache lookup., guix-commits, 2021/02/23
- 04/15: packages: Core procedures are written in monadic style., guix-commits, 2021/02/23
- 02/15: packages: Turn 'bag->derivation' into a monadic procedure., guix-commits, 2021/02/23
- 13/15: grafts: Inline 'grafting?' and 'set-grafting'., guix-commits, 2021/02/23
- 07/15: gexp: 'gexp-inputs' returns a list of <gexp-input> records., guix-commits, 2021/02/23
- 12/15: gexp: Reduce allocations while traversing lists.,
guix-commits <=
- 01/15: build-system: Rewrite using gexps., guix-commits, 2021/02/23
- 15/15: gexp: Reduce allocations in 'gexp-attribute'., guix-commits, 2021/02/23