diff options
| -rw-r--r-- | guix/grafts.scm | 54 |
1 files changed, 35 insertions, 19 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm index eca0a9fcad..af469575db 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -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)))) + + (define (return/cache cache value) + (mbegin %store-monad + (set-current-state (vhash-consq drv value cache)) + (return value))) - ;; 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))))) + (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. |