TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

grafts: Memoize intermediate results in 'cumulative-grafts'. 

The time for:

  guix build inkscape -n --no-substitutes

goes down by 30% (in the presence of 3 replacements among all the
packages.)

* guix/grafts.scm (cumulative-grafts): Turn into a monadic procedure in
%STATE-MONAD.  Use the current state as a derivation-to-graft cache.
(graft-derivation): Call 'cumulative-grafts' within 'run-with-state'.
This commit is contained in:
Ludovic Courtès 2016-03-04 23:10:28 +01:00
parent fcadd9ff9d
commit d4da602e4c
1 changed files with 35 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
guix/grafts.scm
View File

@ -217,7 +217,10 @@ available."
"Augment GRAFTS with additional grafts resulting from the application of
GRAFTS to the dependencies of DRV; REFERENCES must be a one-argument procedure
that returns the list of references of the store item it is given. Return the
resulting list of grafts."
resulting list of grafts.
This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
derivations to the corresponding set of grafts."
(define (dependency-grafts item)
(let-values (((drv output) (item->deriver store item)))
(if drv
@ -225,23 +228,34 @@ resulting list of grafts."
#:outputs (list output)
#:guile guile
#:system system)
grafts)))
(state-return grafts))))
;; TODO: Memoize.
(match (non-self-references references drv outputs)
(() ;no dependencies
grafts)
(deps ;one or more dependencies
(let* ((grafts (delete-duplicates (append-map dependency-grafts deps)
eq?))
(origins (map graft-origin-file-name grafts)))
(if (find (cut member <> deps) origins)
(let ((new (graft-derivation/shallow store drv grafts
#:guile guile
#:system system)))
(cons (graft (origin drv) (replacement new))
grafts))
grafts)))))
(define (return/cache cache value)
(mbegin %store-monad
(set-current-state (vhash-consq drv value cache))
(return value)))
(mlet %state-monad ((cache (current-state)))
(match (vhash-assq drv cache)
((_ . grafts) ;hit
(return grafts))
(#f ;miss
(match (non-self-references references drv outputs)
(() ;no dependencies
(return/cache cache grafts))
(deps ;one or more dependencies
(mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps))
(cache (current-state)))
(let* ((grafts (delete-duplicates (concatenate grafts) equal?))
(origins (map graft-origin-file-name grafts)))
(if (find (cut member <> deps) origins)
(let* ((new (graft-derivation/shallow store drv grafts
#:guile guile
#:system system))
(grafts (cons (graft (origin drv) (replacement new))
grafts)))
(return/cache cache grafts))
(return/cache cache grafts))))))))))
(define* (graft-derivation store drv grafts
#:key (guile (%guile-for-build))
@ -256,8 +270,10 @@ DRV itself to refer to those grafted dependencies."
(define references
(references-oracle store drv))
(match (cumulative-grafts store drv grafts references
#:guile guile #:system system)
(match (run-with-state
(cumulative-grafts store drv grafts references
#:guile guile #:system system)
vlist-null) ;the initial cache
((first . rest)
;; If FIRST is not a graft for DRV, it means that GRAFTS are not
;; applicable to DRV and nothing needs to be done.