summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-05-25 15:22:36 +0200
committerLudovic Courtès <ludo@gnu.org>2016-05-25 23:33:56 +0200
commit1fd11c92592eb4e63d6044c7c840dcb69b9e65e6 (patch)
treec2fa1bbff28e80801f97d7736050bb458fff6932
parent25e0037a2925d56b54ece6e42da838c5be656a52 (diff)
grafts: Create only one grafted variant of each derivation.
Currently, with several grafts applicable to Inkscape, this makes: guix gc -R $(guix build inkscape -d) | wc -l go from 2376 to 2266 (4.6%). * guix/grafts.scm (cumulative-grafts): Pass 'graft-derivation/shallow' the subset of GRAFTS that applies to DRV.
-rw-r--r--guix/grafts.scm27
1 files changed, 17 insertions, 10 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 6bec999ad2..53e697688a 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -252,16 +252,23 @@ derivations to the corresponding set of 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))))))))))
+ (let* ((grafts (delete-duplicates (concatenate grafts) equal?))
+ (origins (map graft-origin-file-name grafts)))
+ (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))
+ (grafts (cons (graft (origin drv) (replacement new))
+ grafts)))
+ (return/cache cache grafts))))))))))))
(define* (graft-derivation store drv grafts
#:key (guile (%guile-for-build))