grafts: Do not pull derivation outputs not depended on.

Fixes <http://bugs.gnu.org/24886>.

Previously, the grafting derivation of, say, brdf-explorer would pull in
qt:doc even though brdf-explorer depends only on qt:out, not qt:doc.

* guix/grafts.scm (with-cache): Use 'vhash-assoc' and 'vhash-cons'
instead of 'vhash-assq' and 'vhash-consq'.
(cumulative-grafts): Pass #:outputs to 'graft-derivation/shallow'.  Use
OUTPUTS instead of (derivation-output-names drv).
(graft-derivation): Add #:outputs parameter; pass it to
'cumulative-grafts'.
* tests/grafts.scm (make-derivation-input): New variable.
("graft-derivation, replaced derivation has multiple outputs"): Make
sure P2:zzz is not part of the outputs of P3D.
("graft-derivation with #:outputs")
("graft-derivation, unused outputs not depended on"): New tests.

guix/grafts.scm

@@ -216,14 +216,14 @@ available."
 (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)
+    (match (vhash-assoc key cache)
       ((_ . result)                               ;cache hit
        (return result))
       (#f                                         ;cache miss
        (mlet %state-monad ((result (begin exp ...))
                            (cache  (current-state)))
          (mbegin %state-monad
-           (set-current-state (vhash-consq key result cache))
+           (set-current-state (vhash-cons key result cache))
            (return result)))))))
 
 (define* (cumulative-grafts store drv grafts
@@ -264,7 +264,7 @@ derivations to the corresponding set of grafts."
                                  #:system system))
           (state-return grafts))))
 
-  (with-cache drv
+  (with-cache (cons (derivation-file-name drv) outputs)
     (match (non-self-references references drv outputs)
       (()                                         ;no dependencies
        (return grafts))
@@ -281,29 +281,27 @@ derivations to the corresponding set of grafts."
               ;; applicable to DRV, to avoid creating several identical
               ;; grafted variants of DRV.
               (let* ((new    (graft-derivation/shallow store drv applicable
+                                                       #:outputs outputs
                                                        #: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))
+                                          outputs)
                                      grafts)))
                 (return grafts))))))))))
 
 (define* (graft-derivation store drv grafts
-                           #:key (guile (%guile-for-build))
+                           #:key
+                           (guile (%guile-for-build))
+                           (outputs (derivation-output-names drv))
                            (system (%current-system)))
-  "Applied GRAFTS to DRV and all its dependencies, recursively.  That is, if
+  "Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
-GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft
+That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
-DRV itself to refer to those grafted dependencies."
+DRV, and graft DRV itself to refer to those grafted dependencies."
 
   ;; First, pre-compute the dependency tree of the outputs of DRV.  Do this
   ;; upfront to have as much parallelism as possible when querying substitute
@@ -313,6 +311,7 @@ DRV itself to refer to those grafted dependencies."
 
   (match (run-with-state
              (cumulative-grafts store drv grafts references
+                                #:outputs outputs
                                 #:guile guile #:system system)
            vlist-null)                            ;the initial cache
     ((first . rest)

tests/grafts.scm

@@ -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.
 ;;;
@@ -43,6 +43,9 @@
 (define %mkdir
   (bootstrap-binary "mkdir"))
 
+(define make-derivation-input
+  (@@ (guix derivations) make-derivation-input))
+
 
 (test-begin "grafts")
 
@@ -241,7 +244,18 @@
                 (replacement p1r)
                 (replacement-output "ONE")))
          (p3d (graft-derivation %store p3 (list p1g))))
-    (and (build-derivations %store (list p3d))
+
+    (and (not (find (lambda (input)
+                      ;; INPUT should not be P2:zzz since the result of P3
+                      ;; does not depend on it.  See
+                      ;; <http://bugs.gnu.org/24886>.
+                      (and (string=? (derivation-input-path input)
+                                     (derivation-file-name p2))
+                           (member "zzz"
+                                   (derivation-input-sub-derivations input))))
+                    (derivation-inputs p3d)))
+
+         (build-derivations %store (list p3d))
          (let ((out (derivation->output-path (pk 'p2d p3d))))
            (and (not (string=? (readlink out)
                                (derivation->output-path p2 "aaa")))
@@ -249,6 +263,106 @@
                           (readlink (string-append out "/two")))
                 (file-exists? (string-append out "/one/replacement")))))))
 
+(test-assert "graft-derivation with #:outputs"
+  ;; Call 'graft-derivation' with a narrowed set of outputs passed as
+  ;; #:outputs.
+  (let* ((p1  (build-expression->derivation
+               %store "p1"
+               `(let ((one (assoc-ref %outputs "one"))
+                      (two (assoc-ref %outputs "two")))
+                  (mkdir one)
+                  (mkdir two))
+               #:outputs '("one" "two")))
+         (p1r (build-expression->derivation
+               %store "P1"
+               `(let ((other (assoc-ref %outputs "ONE")))
+                  (mkdir other)
+                  (call-with-output-file (string-append other "/replacement")
+                    (const #t)))
+               #:outputs '("ONE")))
+         (p2  (build-expression->derivation
+               %store "p2"
+               `(let ((aaa (assoc-ref %outputs "aaa"))
+                      (zzz (assoc-ref %outputs "zzz")))
+                  (mkdir zzz) (chdir zzz)
+                  (mkdir aaa) (chdir aaa)
+                  (symlink (assoc-ref %build-inputs "p1:two") "two"))
+               #:outputs '("aaa" "zzz")
+               #:inputs `(("p1:one" ,p1 "one")
+                          ("p1:two" ,p1 "two"))))
+         (p1g (graft
+                (origin p1)
+                (origin-output "one")
+                (replacement p1r)
+                (replacement-output "ONE")))
+         (p2g (graft-derivation %store p2 (list p1g)
+                                #:outputs '("aaa"))))
+    ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft.
+    (eq? p2g p2)))
+
+(test-equal "graft-derivation, unused outputs not depended on"
+  '("aaa")
+
+  ;; Make sure that the result of 'graft-derivation' does not pull outputs
+  ;; that are irrelevant to the grafting process.  See
+  ;; <http://bugs.gnu.org/24886>.
+  (let* ((p1  (build-expression->derivation
+               %store "p1"
+               `(let ((one (assoc-ref %outputs "one"))
+                      (two (assoc-ref %outputs "two")))
+                  (mkdir one)
+                  (mkdir two))
+               #:outputs '("one" "two")))
+         (p1r (build-expression->derivation
+               %store "P1"
+               `(let ((other (assoc-ref %outputs "ONE")))
+                  (mkdir other)
+                  (call-with-output-file (string-append other "/replacement")
+                    (const #t)))
+               #:outputs '("ONE")))
+         (p2  (build-expression->derivation
+               %store "p2"
+               `(let ((aaa (assoc-ref %outputs "aaa"))
+                      (zzz (assoc-ref %outputs "zzz")))
+                  (mkdir zzz) (chdir zzz)
+                  (symlink (assoc-ref %build-inputs "p1:two") "two")
+                  (mkdir aaa) (chdir aaa)
+                  (symlink (assoc-ref %build-inputs "p1:one") "one"))
+               #:outputs '("aaa" "zzz")
+               #:inputs `(("p1:one" ,p1 "one")
+                          ("p1:two" ,p1 "two"))))
+         (p1g (graft
+                (origin p1)
+                (origin-output "one")
+                (replacement p1r)
+                (replacement-output "ONE")))
+         (p2g (graft-derivation %store p2 (list p1g)
+                                #:outputs '("aaa"))))
+
+    ;; Here P2G should only depend on P1:one and P1R:one; it must not depend
+    ;; on P1:two or P1R:two since these are unused in the grafting process.
+    (and (not (eq? p2g p2))
+         (let* ((inputs      (derivation-inputs p2g))
+                (match-input (lambda (drv)
+                               (lambda (input)
+                                 (string=? (derivation-input-path input)
+                                           (derivation-file-name drv)))))
+                (p1-inputs   (filter (match-input p1) inputs))
+                (p1r-inputs  (filter (match-input p1r) inputs))
+                (p2-inputs   (filter (match-input p2) inputs)))
+           (and (equal? p1-inputs
+                        (list (make-derivation-input (derivation-file-name p1)
+                                                     '("one"))))
+                (equal? p1r-inputs
+                        (list
+                         (make-derivation-input (derivation-file-name p1r)
+                                                '("ONE"))))
+                (equal? p2-inputs
+                        (list
+                         (make-derivation-input (derivation-file-name p2)
+                                                '("aaa"))))
+                (derivation-output-names p2g))))))
+
 (test-assert "graft-derivation, renaming"         ;<http://bugs.gnu.org/23132>
   (let* ((build `(begin
                    (use-modules (guix build utils))