nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

grafts: Move caching to a new 'with-cache' macro. 

* guix/grafts.scm (with-cache): New macro.
(cumulative-grafts)[return/cache]: Remove.
Use 'with-cache' instead.
This commit is contained in:
Ludovic Courtès 2017-01-04 10:43:08 +01:00
parent ddf2b503b1
commit d38bc9a9f6
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 47 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
guix/grafts.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -214,6 +214,17 @@ available."
(delete-duplicates (concatenate refs) string=?)) (delete-duplicates (concatenate refs) string=?))
result)))))) 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 (define* (cumulative-grafts store drv grafts
references references
#:key #:key
@ -252,19 +263,10 @@ derivations to the corresponding set of grafts."
#:system system)) #:system system))
(state-return grafts)))) (state-return grafts))))
(define (return/cache cache value) (with-cache drv
(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
(return grafts))
(#f ;miss
(match (non-self-references references drv outputs) (match (non-self-references references drv outputs)
(() ;no dependencies (() ;no dependencies
(return/cache cache grafts)) (return grafts))
(deps ;one or more dependencies (deps ;one or more dependencies
(mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps))) (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps)))
(let ((grafts (delete-duplicates (concatenate grafts) equal?))) (let ((grafts (delete-duplicates (concatenate grafts) equal?)))
@ -272,7 +274,7 @@ derivations to the corresponding set of grafts."
(member (graft-origin-file-name graft) deps)) (member (graft-origin-file-name graft) deps))
grafts) grafts)
(() (()
(return/cache cache grafts)) (return grafts))
((applicable ..1) ((applicable ..1)
;; Use APPLICABLE, the subset of GRAFTS that is really ;; Use APPLICABLE, the subset of GRAFTS that is really
;; applicable to DRV, to avoid creating several identical ;; applicable to DRV, to avoid creating several identical
@ -293,7 +295,7 @@ derivations to the corresponding set of grafts."
(replacement-output output))) (replacement-output output)))
(derivation-output-names drv)) (derivation-output-names drv))
grafts))) grafts)))
(return/cache cache grafts)))))))))))) (return grafts))))))))))
(define* (graft-derivation store drv grafts (define* (graft-derivation store drv grafts
#:key (guile (%guile-for-build)) #:key (guile (%guile-for-build))
@ -333,4 +335,8 @@ it otherwise. It returns the previous setting."
(lambda (store) (lambda (store)
(values (%graft? enable?) store))) (values (%graft? enable?) store)))
;; Local Variables:
;; eval: (put 'with-cache 'scheme-indent-function 1)
;; End:
;;; grafts.scm ends here ;;; grafts.scm ends here