summaryrefslogtreecommitdiff
path: root/guix/packages.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-02-27 23:06:50 +0100
committerLudovic Courtès <ludo@gnu.org>2016-03-01 16:00:46 +0100
commitc22a1324e64d6906be5e9a8e64b8716ad763434a (patch)
treea85accaeaa4c727c703f208e01a9296821832de7 /guix/packages.scm
parentd06fc008bdb86169d951721bbb4604948368d7c2 (diff)
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.
Diffstat (limited to 'guix/packages.scm')
-rw-r--r--guix/packages.scm126
1 files changed, 83 insertions, 43 deletions
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))))