rekahsoft
/
guix
1
1
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
;;; 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))
(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/cache cache grafts))))))))))))
;; 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