Merge branch 'master' into core-updates

1 files changed, 23 insertions, 9 deletions

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 53e697688a..80ae27e9b0 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -227,17 +227,33 @@ resulting list of grafts.
 
 This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
 derivations to the corresponding set of grafts."
+  (define (graft-origin? drv graft)
+    ;; Return true if DRV corresponds to the origin of GRAFT.
+    (match graft
+      (($ <graft> (? derivation? origin) output)
+       (match (assoc-ref (derivation->output-paths drv) output)
+         ((? string? result)
+          (string=? result
+                    (derivation->output-path origin output)))
+         (_
+          #f)))
+      (_
+       #f)))
+
   (define (dependency-grafts item)
     (let-values (((drv output) (item->deriver store item)))
       (if drv
-          (cumulative-grafts store drv grafts references
-                             #:outputs (list output)
-                             #:guile guile
-                             #:system system)
+          ;; If GRAFTS already contains a graft from DRV, do not override it.
+          (if (find (cut graft-origin? drv <>) grafts)
+              (state-return grafts)
+              (cumulative-grafts store drv grafts references
+                                 #:outputs (list output)
+                                 #:guile guile
+                                 #:system system))
           (state-return grafts))))
 
   (define (return/cache cache value)
-    (mbegin %store-monad
+    (mbegin %state-monad
       (set-current-state (vhash-consq drv value cache))
       (return value)))
 
@@ -250,10 +266,8 @@ derivations to the corresponding set of grafts."
          (()                                      ;no dependencies
           (return/cache cache 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)))
+          (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)