[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: grafts: Graft recursively.
|
From: |
Ludovic Courtès |
|
Subject: |
01/01: grafts: Graft recursively. |
|
Date: |
Mon, 29 Feb 2016 23:22:32 +0000 |
civodul pushed a commit to branch wip-recursive-grafts
in repository guix.
commit 9f5b48ef1209a9be98a626a3aa3ca5b29e0ded11
Author: Ludovic Courtès <address@hidden>
Date: Sat Feb 27 23:06:50 2016 +0100
grafts: Graft recursively.
Fixes <http://bugs.gnu.org/22139>.
* guix/grafts.scm (graft-derivation): Rename to...
(graft-derivation/shallow): ... this.
(graft-origin-file-name, item->deriver, non-self-references)
(cumulative-grafts, graft-derivation): New procedures
* tests/grafts.scm ("graft-derivation, grafted item is a direct
dependency"): Clarify title. Use 'grafted' instead of 'graft' to refer
to the grafted derivation.
("graft-derivation, grafted item is an indirect dependency")
("graft-derivation, no dependencies on grafted output"): New tests.
* guix/packages.scm (input-graft): Change to take a package instead of
an input.
(input-cross-graft): Likewise.
(fold-bag-dependencies): New procedure.
(bag-grafts): Rewrite in terms of 'fold-bag-dependencies'.
* tests/packages.scm ("package-derivation, indirect grafts"): Comment out.
* doc/guix.texi (Security Updates): Mention run-time dependencies and
recursive grafting.
---
doc/guix.texi | 9 ++-
guix/grafts.scm | 104 +++++++++++++++++++++++++++++++++++++--
guix/packages.scm | 126 +++++++++++++++++++++++++++++++----------------
guix/scripts/graph.scm | 5 ++-
tests/grafts.scm | 93 +++++++++++++++++++++++++++++------
tests/packages.scm | 38 ++++++++-------
6 files changed, 290 insertions(+), 85 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 4c9a91b..5e62703 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10244,11 +10244,14 @@ Packages}). Then, the original package definition is
augmented with a
(replacement bash-fixed)))
@end example
-From there on, any package depending directly or indirectly on Bash that
-is installed will automatically be ``rewritten'' to refer to
+From there on, any package depending directly or indirectly on Bash---as
+reported by @command{guix gc --requisites} (@pxref{Invoking guix
+gc})---that is installed is automatically ``rewritten'' to refer to
@var{bash-fixed} instead of @var{bash}. This grafting process takes
time proportional to the size of the package, but expect less than a
-minute for an ``average'' package on a recent machine.
+minute for an ``average'' package on a recent machine. Grafting is
+recursive: when an indirect dependency requires grafting, then grafting
+``propagates'' up to the package that the user is installing.
Currently, the graft and the package it replaces (@var{bash-fixed} and
@var{bash} in the example above) must have the exact same @code{name}
diff --git a/guix/grafts.scm b/guix/grafts.scm
index ea53959..9bcc5e2 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -17,11 +17,14 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix grafts)
+ #:use-module (guix store)
+ #:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module ((guix utils) #:select (%current-system))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (graft?
@@ -32,6 +35,7 @@
graft-replacement-output
graft-derivation
+ graft-derivation/shallow
%graft?
set-grafting))
@@ -61,13 +65,22 @@
(set-record-type-printer! <graft> write-graft)
-(define* (graft-derivation store drv grafts
- #:key
- (name (derivation-name drv))
- (guile (%guile-for-build))
- (system (%current-system)))
+(define (graft-origin-file-name graft)
+ "Return the output file name of the origin of GRAFT."
+ (match graft
+ (($ <graft> (? derivation? origin) output)
+ (derivation->output-path origin output))
+ (($ <graft> (? string? item))
+ item)))
+
+(define* (graft-derivation/shallow store drv grafts
+ #:key
+ (name (derivation-name drv))
+ (guile (%guile-for-build))
+ (system (%current-system)))
"Return a derivation called NAME, based on DRV but with all the GRAFTS
-applied."
+applied. This procedure performs \"shallow\" grafting in that GRAFTS are not
+recursively applied to dependencies of DRV."
;; XXX: Someday rewrite using gexps.
(define mapping
;; List of store item pairs.
@@ -133,6 +146,85 @@ applied."
(map add-label
targets)))
#:outputs output-names
#:local-build? #t)))))
+(define (item->deriver store item)
+ "Return two values: the derivation that led to ITEM (a store item), and the
+name of the output of that derivation ITEM corresponds to (for example
+\"out\"). When ITEM has no deriver, for instance because it is a plain file,
+#f and #f are returned."
+ (match (valid-derivers store item)
+ (() ;ITEM is a plain file
+ (values #f #f))
+ ((drv-file _ ...)
+ (let ((drv (call-with-input-file drv-file read-derivation)))
+ (values drv
+ (any (match-lambda
+ ((name . path)
+ (and (string=? item path) name)))
+ (derivation->output-paths drv)))))))
+
+(define (non-self-references store drv outputs)
+ "Return the list of references of the OUTPUTS of DRV, excluding self
+references."
+ (let ((refs (append-map (lambda (output)
+ (references store
+ (derivation->output-path drv output)))
+ outputs))
+ (self (match (derivation->output-paths drv)
+ (((names . items) ...)
+ items))))
+ (remove (cut member <> self) refs)))
+
+(define* (cumulative-grafts store drv grafts
+ #:key
+ (outputs (derivation-output-names drv))
+ (guile (%guile-for-build))
+ (system (%current-system)))
+ "Augment GRAFTS with additional grafts resulting from the application of
+GRAFTS to the dependencies of DRV. Return the resulting list of grafts."
+ (define (dependency-grafts item)
+ (let-values (((drv output) (item->deriver store item)))
+ (if drv
+ (cumulative-grafts store drv grafts
+ #:outputs (list output)
+ #:guile guile
+ #:system system)
+ grafts)))
+
+ ;; TODO: Memoize.
+ (match (non-self-references store drv outputs)
+ (() ;no dependencies
+ grafts)
+ (deps ;one or more dependencies
+ (let* ((grafts (delete-duplicates (append-map dependency-grafts deps)
+ eq?))
+ (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)))
+ (cons (graft (origin drv) (replacement new))
+ grafts))
+ grafts)))))
+
+(define* (graft-derivation store drv grafts
+ #:key (guile (%guile-for-build))
+ (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."
+
+ ;; First, we need to build the ungrafted DRV so we can query its run-time
+ ;; dependencies in 'cumulative-grafts'.
+ (build-derivations store (list drv))
+
+ (match (cumulative-grafts store drv grafts
+ #:guile guile #:system system)
+ ((first . rest)
+ ;; If FIRST is not a graft for DRV, it means that GRAFTS are not
+ ;; applicable to DRV and nothing needs to be done.
+ (if (equal? drv (graft-origin first))
+ (graft-replacement first)
+ drv))))
;; The following might feel more at home in (guix packages) but since (guix
diff --git a/guix/packages.scm b/guix/packages.scm
index f6afaeb..3e50260 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -30,6 +30,7 @@
#:use-module (guix build-system)
#:use-module (guix search-paths)
#:use-module (guix gexp)
+ #:use-module (guix sets)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
@@ -831,30 +832,25 @@ and return it."
(package package))))))))))
(define (input-graft store system)
- "Return a procedure that, given an input referring to a package with a
-graft, returns a pair with the original derivation and the graft's derivation,
-and returns #f for other inputs."
+ "Return a procedure that, given a package with a graft, returns a graft, and
+#f otherwise."
(match-lambda
- ((label (? package? package) sub-drv ...)
- (let ((replacement (package-replacement package)))
- (and replacement
- (let ((orig (package-derivation store package system
- #:graft? #f))
- (new (package-derivation store replacement system)))
- (graft
- (origin orig)
- (replacement new)
- (origin-output (match sub-drv
- (() "out")
- ((output) output)))
- (replacement-output origin-output))))))
- (x
- #f)))
+ ((? package? package)
+ (let ((replacement (package-replacement package)))
+ (and replacement
+ (let ((orig (package-derivation store package system
+ #:graft? #f))
+ (new (package-derivation store replacement system)))
+ (graft
+ (origin orig)
+ (replacement new))))))
+ (x
+ #f)))
(define (input-cross-graft store target system)
"Same as 'input-graft', but for cross-compilation inputs."
(match-lambda
- ((label (? package? package) sub-drv ...)
+ ((? package? package)
(let ((replacement (package-replacement package)))
(and replacement
(let ((orig (package-cross-derivation store package target system
@@ -863,34 +859,75 @@ and returns #f for other inputs."
target system)))
(graft
(origin orig)
- (replacement new)
- (origin-output (match sub-drv
- (() "out")
- ((output) output)))
- (replacement-output origin-output))))))
+ (replacement new))))))
(_
#f)))
-(define* (bag-grafts store bag)
- "Return the list of grafts applicable to BAG. Each graft is a <graft>
-record."
- (let ((target (bag-target bag))
- (system (bag-system bag)))
- (define native-grafts
- (filter-map (input-graft store system)
- (append (bag-transitive-build-inputs bag)
- (bag-transitive-target-inputs bag)
- (if target
- '()
- (bag-transitive-host-inputs bag)))))
-
- (define target-grafts
- (if target
- (filter-map (input-cross-graft store target system)
- (bag-transitive-host-inputs bag))
- '()))
+(define* (fold-bag-dependencies proc seed bag
+ #:key (native? #t))
+ "Fold PROC over the packages BAG depends on. Each package is visited only
+once, in depth-first order. If NATIVE? is true, restrict to native
+dependencies; otherwise, restrict to target dependencies."
+ (define nodes
+ (match (if native?
+ (append (bag-build-inputs bag)
+ (bag-target-inputs bag)
+ (if (bag-target bag)
+ '()
+ (bag-host-inputs bag)))
+ (bag-host-inputs bag))
+ (((labels things _ ...) ...)
+ things)))
+
+ (let loop ((nodes nodes)
+ (result seed)
+ (visited (setq)))
+ (match nodes
+ (()
+ result)
+ (((? package? head) . tail)
+ (if (set-contains? visited head)
+ (loop tail result visited)
+ (let ((inputs (bag-direct-inputs (package->bag head))))
+ (loop (match inputs
+ (((labels things _ ...) ...)
+ (append things tail)))
+ (proc head result)
+ (set-insert head visited)))))
+ ((head . tail)
+ (loop tail result visited)))))
- (append native-grafts target-grafts)))
+(define* (bag-grafts store bag)
+ "Return the list of grafts potentially applicable to BAG. Potentially
+applicable grafts are collected by looking at direct or indirect dependencies
+of BAG that have a 'replacement'. Whether a graft is actually applicable
+depends on whether the outputs of BAG depend on the items the grafts refer
+to (see 'graft-derivation'.)"
+ (define system (bag-system bag))
+ (define target (bag-target bag))
+
+ (define native-grafts
+ (let ((->graft (input-graft store system)))
+ (fold-bag-dependencies (lambda (package grafts)
+ (match (->graft package)
+ (#f grafts)
+ (graft (cons graft grafts))))
+ '()
+ bag)))
+
+ (define target-grafts
+ (if target
+ (let ((->graft (input-cross-graft store target system)))
+ (fold-bag-dependencies (lambda (package grafts)
+ (match (->graft package)
+ (#f grafts)
+ (graft (cons graft grafts))))
+ '()
+ bag
+ #:native? #f))
+ '()))
+
+ (append native-grafts target-grafts))
(define* (package-grafts store package
#:optional (system (%current-system))
@@ -985,6 +1022,9 @@ This is an internal procedure."
(grafts
(let ((guile (package-derivation store (default-guile)
system #:graft? #f)))
+ ;; TODO: As an optimization, we can simply graft the tip
+ ;; of the derivation graph since 'graft-derivation'
+ ;; recurses anyway.
(graft-derivation store drv grafts
#:system system
#:guile guile))))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index dcc4701..2d1c1ff 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -19,6 +19,7 @@
(define-module (guix scripts graph)
#:use-module (guix ui)
#:use-module (guix graph)
+ #:use-module (guix grafts)
#:use-module (guix scripts)
#:use-module (guix utils)
#:use-module (guix packages)
@@ -352,7 +353,9 @@ Emit a Graphviz (dot) representation of the dependencies of
PACKAGE...\n"))
opts)))
(with-store store
(run-with-store store
- (mlet %store-monad ((nodes (mapm %store-monad
+ ;; XXX: Since grafting can trigger unsolicited builds, disable it.
+ (mlet %store-monad ((_ (set-grafting #f))
+ (nodes (mapm %store-monad
(node-type-convert type)
packages)))
(export-graph (concatenate nodes)
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 9fe314d..4bc3370 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -17,12 +17,16 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-grafts)
+ #:use-module (guix gexp)
+ #:use-module (guix monads)
#:use-module (guix derivations)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix grafts)
#:use-module (guix tests)
#:use-module ((gnu packages) #:select (search-bootstrap-binary))
+ #:use-module (gnu packages bootstrap)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
#:use-module (rnrs io ports))
@@ -42,7 +46,7 @@
(test-begin "grafts")
-(test-assert "graft-derivation"
+(test-assert "graft-derivation, grafted item is a direct dependency"
(let* ((build `(begin
(mkdir %output)
(chdir %output)
@@ -51,7 +55,7 @@
(lambda (output)
(format output "foo/~a/bar" ,%mkdir)))
(symlink ,%bash "sh")))
- (orig (build-expression->derivation %store "graft" build
+ (orig (build-expression->derivation %store "grafted" build
#:inputs `(("a" ,%bash)
("b" ,%mkdir))))
(one (add-text-to-store %store "bash" "fake bash"))
@@ -59,21 +63,80 @@
'(call-with-output-file %output
(lambda (port)
(display "fake mkdir"
port)))))
- (graft (graft-derivation %store orig
- (list (graft
- (origin %bash)
- (replacement one))
- (graft
- (origin %mkdir)
- (replacement two))))))
- (and (build-derivations %store (list graft))
- (let ((two (derivation->output-path two))
- (graft (derivation->output-path graft)))
+ (grafted (graft-derivation %store orig
+ (list (graft
+ (origin %bash)
+ (replacement one))
+ (graft
+ (origin %mkdir)
+ (replacement two))))))
+ (and (build-derivations %store (list grafted))
+ (let ((two (derivation->output-path two))
+ (grafted (derivation->output-path grafted)))
(and (string=? (format #f "foo/~a/bar" two)
- (call-with-input-file (string-append graft "/text")
+ (call-with-input-file (string-append grafted "/text")
get-string-all))
- (string=? (readlink (string-append graft "/sh")) one)
- (string=? (readlink (string-append graft "/self")) graft))))))
+ (string=? (readlink (string-append grafted "/sh")) one)
+ (string=? (readlink (string-append grafted "/self"))
+ grafted))))))
+
+;; Make sure 'derivation-file-name' always gets to see an absolute file name.
+(fluid-set! %file-port-name-canonicalization 'absolute)
+
+(test-assert "graft-derivation, grafted item is an indirect dependency"
+ (let* ((build `(begin
+ (mkdir %output)
+ (chdir %output)
+ (symlink %output "self")
+ (call-with-output-file "text"
+ (lambda (output)
+ (format output "foo/~a/bar" ,%mkdir)))
+ (symlink ,%bash "sh")))
+ (dep (build-expression->derivation %store "dep" build
+ #:inputs `(("a" ,%bash)
+ ("b" ,%mkdir))))
+ (orig (build-expression->derivation %store "thing"
+ '(symlink
+ (assoc-ref %build-inputs
+ "dep")
+ %output)
+ #:inputs `(("dep" ,dep))))
+ (one (add-text-to-store %store "bash" "fake bash"))
+ (two (build-expression->derivation %store "mkdir"
+ '(call-with-output-file %output
+ (lambda (port)
+ (display "fake mkdir"
port)))))
+ (grafted (graft-derivation %store orig
+ (list (graft
+ (origin %bash)
+ (replacement one))
+ (graft
+ (origin %mkdir)
+ (replacement two))))))
+ (and (build-derivations %store (list grafted))
+ (let* ((two (derivation->output-path two))
+ (grafted (derivation->output-path grafted))
+ (dep (readlink grafted)))
+ (and (string=? (format #f "foo/~a/bar" two)
+ (call-with-input-file (string-append dep "/text")
+ get-string-all))
+ (string=? (readlink (string-append dep "/sh")) one)
+ (string=? (readlink (string-append dep "/self")) dep)
+ (equal? (references %store grafted) (list dep))
+ (lset= string=?
+ (list one two dep)
+ (references %store dep)))))))
+
+(test-assert "graft-derivation, no dependencies on grafted output"
+ (run-with-store %store
+ (mlet* %store-monad ((fake (text-file "bash" "Fake bash."))
+ (graft -> (graft
+ (origin %bash)
+ (replacement fake)))
+ (drv (gexp->derivation "foo" #~(mkdir #$output)))
+ (grafted ((store-lift graft-derivation) drv
+ (list graft))))
+ (return (eq? grafted drv)))))
(test-assert "graft-derivation, multiple outputs"
(let* ((build `(begin
diff --git a/tests/packages.scm b/tests/packages.scm
index 6315c22..4639178 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -605,23 +605,27 @@
(origin (package-derivation %store dep))
(replacement (package-derivation %store new)))))))
-(test-assert "package-derivation, indirect grafts"
- (let* ((new (dummy-package "dep"
- (arguments '(#:implicit-inputs? #f))))
- (dep (package (inherit new) (version "0.0")))
- (dep* (package (inherit dep) (replacement new)))
- (dummy (dummy-package "dummy"
- (arguments '(#:implicit-inputs? #f))
- (inputs `(("dep" ,dep*)))))
- (guile (package-derivation %store (canonical-package guile-2.0)
- #:graft? #f)))
- (equal? (package-derivation %store dummy)
- (graft-derivation %store
- (package-derivation %store dummy #:graft? #f)
- (package-grafts %store dummy)
-
- ;; Use the same Guile as 'package-derivation'.
- #:guile guile))))
+;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
+;;; find out about their run-time dependencies, so this test is no longer
+;;; applicable since it would trigger a full rebuild.
+;;
+;; (test-assert "package-derivation, indirect grafts"
+;; (let* ((new (dummy-package "dep"
+;; (arguments '(#:implicit-inputs? #f))))
+;; (dep (package (inherit new) (version "0.0")))
+;; (dep* (package (inherit dep) (replacement new)))
+;; (dummy (dummy-package "dummy"
+;; (arguments '(#:implicit-inputs? #f))
+;; (inputs `(("dep" ,dep*)))))
+;; (guile (package-derivation %store (canonical-package guile-2.0)
+;; #:graft? #f)))
+;; (equal? (package-derivation %store dummy)
+;; (graft-derivation %store
+;; (package-derivation %store dummy #:graft? #f)
+;; (package-grafts %store dummy)
+
+;; ;; Use the same Guile as 'package-derivation'.
+;; #:guile guile))))
(test-equal "package->bag"
`("foo86-hurd" #f (,(package-source gnu-make))