futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

store: Use a decaying cutoff in 'map/accumulate-builds'.

Browse Source 
This reduces the wall-clock time of:

  ./pre-inst-env guix system vm gnu/system/examples/desktop.tmpl -n

from 2m13s to 53s (the timings depend on which derivations have already
been built and are in store; in this case, many were missing).

* guix/store.scm (default-cutoff): New variable.
(map/accumulate-builds): Use it.  Parameterize it in recursive calls to
have decaying cutoff.
This commit is contained in:
Ludovic Courtès 2022-05-13 16:47:49 +02:00
parent 001f4afd07
commit 2f17089371
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 23 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
guix/store.scm
View File

@ -1362,8 +1362,12 @@ object, only for build requests on EXPECTED-STORE."
(unresolved things continue)
(continue #t))))
(define default-cutoff
;; Default cutoff parameter for 'map/accumulate-builds'.
(make-parameter 32))
(define* (map/accumulate-builds store proc lst
#:key (cutoff 30))
#:key (cutoff (default-cutoff)))
"Apply PROC over each element of LST, accumulating 'build-things' calls and
coalescing them into a single call.
@ -1377,21 +1381,24 @@ CUTOFF is the threshold above which we stop accumulating unresolved nodes."
(build-accumulator store))
(define-values (result rest)
(let loop ((lst lst)
(result '())
(unresolved 0))
(match lst
((head . tail)
(match (with-build-handler accumulator
(proc head))
((? unresolved? obj)
(if (>= unresolved cutoff)
(values (reverse (cons obj result)) tail)
(loop tail (cons obj result) (+ 1 unresolved))))
(obj
(loop tail (cons obj result) unresolved))))
(()
(values (reverse result) lst)))))
;; Have the default cutoff decay as we go deeper in the call stack to
;; avoid pessimal behavior.
(parameterize ((default-cutoff (quotient cutoff 2)))
(let loop ((lst lst)
(result '())
(unresolved 0))
(match lst
((head . tail)
(match (with-build-handler accumulator
(proc head))
((? unresolved? obj)
(if (>= unresolved cutoff)
(values (reverse (cons obj result)) tail)
(loop tail (cons obj result) (+ 1 unresolved))))
(obj
(loop tail (cons obj result) unresolved))))
(()
(values (reverse result) lst))))))
(match (append-map (lambda (obj)
(if (unresolved? obj)