me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2017-01-25 10:20:02 +01:00
parent ad91454281
commit 482fda2729
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 128 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
guix/grafts.scm
View File

@ -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
GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft
DRV itself to refer to those grafted dependencies."
"Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
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)

118
tests/grafts.scm
View File

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