diff options
| -rw-r--r-- | doc/guix.texi | 9 | ||||
| -rw-r--r-- | guix/grafts.scm | 104 | ||||
| -rw-r--r-- | guix/packages.scm | 126 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 5 | ||||
| -rw-r--r-- | tests/grafts.scm | 93 | ||||
| -rw-r--r-- | tests/packages.scm | 38 |
6 files changed, 290 insertions, 85 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 4c9a91b399..5e62703380 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 ea53959b37..9bcc5e2ef8 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 f6afaeb510..3e50260069 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 dcc4701779..2d1c1ff59f 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 9fe314d183..4bc33709d6 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 6315c2204f..46391783b0 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)) |