[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: grafts: Do not pull derivation outputs not depended on.
|
From: |
Ludovic Courtès |
|
Subject: |
01/01: grafts: Do not pull derivation outputs not depended on. |
|
Date: |
Wed, 25 Jan 2017 10:05:11 +0000 (UTC) |
civodul pushed a commit to branch master
in repository guix.
commit 482fda2729c3e76999892cb8f9a0391a7bd37119
Author: Ludovic Courtès <address@hidden>
Date: Wed Jan 25 10:20:02 2017 +0100
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 | 25 ++++++------
tests/grafts.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 128 insertions(+), 15 deletions(-)
diff --git a/guix/grafts.scm b/guix/grafts.scm
index e44fc05..11885db 100644
--- a/guix/grafts.scm
+++ b/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
-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)
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 6454a03..08f05c0 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
;;;
;;; 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))