mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 13:58:15 -05:00
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:
parent
fcadd9ff9d
commit
d4da602e4c
1 changed files with 35 additions and 19 deletions
|
@ -217,7 +217,10 @@ (define* (cumulative-grafts store drv grafts
|
|||
"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 @@ (define (dependency-grafts item)
|
|||
#:outputs (list output)
|
||||
#:guile guile
|
||||
#:system system)
|
||||
grafts)))
|
||||
(state-return grafts))))
|
||||
|
||||
;; TODO: Memoize.
|
||||
(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
|
||||
grafts)
|
||||
(return/cache cache grafts))
|
||||
(deps ;one or more dependencies
|
||||
(let* ((grafts (delete-duplicates (append-map dependency-grafts deps)
|
||||
eq?))
|
||||
(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
|
||||
(let* ((new (graft-derivation/shallow store drv grafts
|
||||
#:guile guile
|
||||
#:system system)))
|
||||
(cons (graft (origin drv) (replacement new))
|
||||
grafts))
|
||||
grafts)))))
|
||||
#: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 @@ (define* (graft-derivation store drv grafts
|
|||
(define references
|
||||
(references-oracle store drv))
|
||||
|
||||
(match (cumulative-grafts store drv grafts references
|
||||
(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.
|
||||
|
|
Loading…
Reference in a new issue