~ruther/guix-local: grafts: Create only one grafted variant of each derivation.

1fd11c92592eb4e63d6044c7c840dcb69b9e65e6 — Ludovic Courtès 10 years ago 25e0037

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.

patch browse .tar.gz

1 files changed, 17 insertions(+), 10 deletions(-)

M guix/grafts.scm

M guix/grafts.scm => guix/grafts.scm +17 -10

@@ 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))