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

88
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,48 +263,39 @@ 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 (match (non-self-references references drv outputs)
(set-current-state (vhash-consq drv value cache)) (() ;no dependencies
(return value)))
(mlet %state-monad ((cache (current-state)))
(match (vhash-assq drv cache)
((_ . grafts) ;hit
(return grafts)) (return grafts))
(#f ;miss (deps ;one or more dependencies
(match (non-self-references references drv outputs) (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps)))
(() ;no dependencies (let ((grafts (delete-duplicates (concatenate grafts) equal?)))
(return/cache cache grafts)) (match (filter (lambda (graft)
(deps ;one or more dependencies (member (graft-origin-file-name graft) deps))
(mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps))) grafts)
(let ((grafts (delete-duplicates (concatenate grafts) equal?))) (()
(match (filter (lambda (graft) (return grafts))
(member (graft-origin-file-name graft) deps)) ((applicable ..1)
grafts) ;; Use APPLICABLE, the subset of GRAFTS that is really
(() ;; applicable to DRV, to avoid creating several identical
(return/cache cache grafts)) ;; grafted variants of DRV.
((applicable ..1) (let* ((new (graft-derivation/shallow store drv applicable
;; Use APPLICABLE, the subset of GRAFTS that is really #:guile guile
;; applicable to DRV, to avoid creating several identical #:system system))
;; 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, ;; Replace references to any of the outputs of DRV,
;; even if that's more than needed. This is so that ;; even if that's more than needed. This is so that
;; the result refers only to the outputs of NEW and ;; the result refers only to the outputs of NEW and
;; not to those of DRV. ;; not to those of DRV.
(grafts (append (map (lambda (output) (grafts (append (map (lambda (output)
(graft (graft
(origin drv) (origin drv)
(origin-output output) (origin-output output)
(replacement new) (replacement new)
(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