01/01: grafts: Create only one grafted variant of each derivation.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 1fd11c92592eb4e63d6044c7c840dcb69b9e65e6
Author: Ludovic Courtès <address@hidden>
Date:   Wed May 25 15:22:36 2016 +0200

    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.
---
 guix/grafts.scm |   27 +++++++++++++++++----------
 1 file changed, 17 insertions(+), 10 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 6bec999..53e6976 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))