diff options
| -rw-r--r-- | guix/grafts.scm | 90 |
1 files changed, 48 insertions, 42 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm index dda7c1d235..2006d3908e 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -214,6 +214,17 @@ available." (delete-duplicates (concatenate refs) string=?)) result)))))) +(define-syntax-rule (with-cache key exp ...) + "Cache the value of monadic expression EXP under KEY." + (mlet %state-monad ((cache (current-state))) + (match (vhash-assq key cache) + ((_ . result) ;cache hit + (return result)) + (#f ;cache miss + (mlet %state-monad ((result (begin exp ...))) + (set-current-state (vhash-consq key result cache)) + (return result)))))) + (define* (cumulative-grafts store drv grafts references #:key @@ -252,48 +263,39 @@ derivations to the corresponding set of grafts." #:system system)) (state-return grafts)))) - (define (return/cache cache value) - (mbegin %state-monad - (set-current-state (vhash-consq drv value cache)) - (return value))) - - (mlet %state-monad ((cache (current-state))) - (match (vhash-assq drv cache) - ((_ . grafts) ;hit + (with-cache drv + (match (non-self-references references drv outputs) + (() ;no dependencies (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))) - (let ((grafts (delete-duplicates (concatenate grafts) equal?))) - (match (filter (lambda (graft) - (member (graft-origin-file-name graft) deps)) - grafts) - (() - (return/cache cache grafts)) - ((applicable ..1) - ;; Use APPLICABLE, the subset of GRAFTS that is really - ;; applicable to DRV, to avoid creating several identical - ;; grafted variants of DRV. - (let* ((new (graft-derivation/shallow store drv applicable - #:guile guile - #:system system)) - - ;; Replace references to any of the outputs of DRV, - ;; even if that's more than needed. This is so that - ;; the result refers only to the outputs of NEW and - ;; not to those of DRV. - (grafts (append (map (lambda (output) - (graft - (origin drv) - (origin-output output) - (replacement new) - (replacement-output output))) - (derivation-output-names drv)) - grafts))) - (return/cache cache grafts)))))))))))) + (deps ;one or more dependencies + (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps))) + (let ((grafts (delete-duplicates (concatenate grafts) equal?))) + (match (filter (lambda (graft) + (member (graft-origin-file-name graft) deps)) + grafts) + (() + (return grafts)) + ((applicable ..1) + ;; Use APPLICABLE, the subset of GRAFTS that is really + ;; applicable to DRV, to avoid creating several identical + ;; grafted variants of DRV. + (let* ((new (graft-derivation/shallow store drv applicable + #:guile guile + #:system system)) + + ;; Replace references to any of the outputs of DRV, + ;; even if that's more than needed. This is so that + ;; the result refers only to the outputs of NEW and + ;; not to those of DRV. + (grafts (append (map (lambda (output) + (graft + (origin drv) + (origin-output output) + (replacement new) + (replacement-output output))) + (derivation-output-names drv)) + grafts))) + (return grafts)))))))))) (define* (graft-derivation store drv grafts #:key (guile (%guile-for-build)) @@ -333,4 +335,8 @@ it otherwise. It returns the previous setting." (lambda (store) (values (%graft? enable?) store))) +;; Local Variables: +;; eval: (put 'with-cache 'scheme-indent-function 1) +;; End: + ;;; grafts.scm ends here |