summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-06-19 22:05:06 +0200
committerLudovic Courtès <ludo@gnu.org>2019-06-27 11:14:41 +0200
commitba04f80e2e0fd92ca381c8fac8a659cb8f9abdd2 (patch)
tree2806aa302d627975d759725ddbb3f5c2c226d566
parentc89985d91d2b44704fbcaebd7a097dee0c0e3e4a (diff)
derivations: Rewrite and replace 'derivations-prerequisites-to-build'.
The new 'derivation-build-plan' procedure has a more appropriate signature: it takes a list of <derivation-inputs> instead of taking one <derivation>. Its body is also much simpler. * guix/derivations.scm (derivation-build-plan): New procedure. (derivation-prerequisites-to-build): Express in terms of 'derivation-build-plan' and mark as deprecated. * tests/derivations.scm: Change 'derivation-prerequisites-to-build' tests to 'derivation-build-plan' and adjust accordingly.
-rw-r--r--guix/derivations.scm138
-rw-r--r--tests/derivations.scm63
2 files changed, 100 insertions, 101 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 4df7b06181..f6e94694fd 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -21,6 +21,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
@@ -34,6 +35,7 @@
#:use-module (guix base16)
#:use-module (guix memoization)
#:use-module (guix combinators)
+ #:use-module (guix deprecation)
#:use-module (guix monads)
#:use-module (gcrypt hash)
#:use-module (guix base32)
@@ -50,7 +52,8 @@
derivation-builder-environment-vars
derivation-file-name
derivation-prerequisites
- derivation-prerequisites-to-build
+ derivation-build-plan
+ derivation-prerequisites-to-build ;deprecated
<derivation-output>
derivation-output?
@@ -61,6 +64,7 @@
<derivation-input>
derivation-input?
+ derivation-input
derivation-input-path
derivation-input-derivation
derivation-input-sub-derivations
@@ -341,82 +345,70 @@ substituter many times."
(#f #f)
((key . value) value)))))
-(define* (derivation-prerequisites-to-build store drv
- #:key
- (mode (build-mode normal))
- (outputs
- (derivation-output-names drv))
- (substitutable-info
- (substitution-oracle store
- (list drv)
- #:mode mode)))
- "Return two values: the list of derivation-inputs required to build the
-OUTPUTS of DRV and not already available in STORE, recursively, and the list
-of required store paths that can be substituted. SUBSTITUTABLE-INFO must be a
-one-argument procedure similar to that returned by 'substitution-oracle'."
- (define built?
- (mlambda (item)
- (valid-path? store item)))
-
- (define input-built?
- (compose (cut any built? <>) derivation-input-output-paths))
-
- (define input-substitutable?
- ;; Return true if and only if all of SUB-DRVS are subsitutable. If at
- ;; least one is missing, then everything must be rebuilt.
- (compose (cut every substitutable-info <>) derivation-input-output-paths))
-
- (define (derivation-built? drv* sub-drvs)
+(define* (derivation-build-plan store inputs
+ #:key
+ (mode (build-mode normal))
+ (substitutable-info
+ (substitution-oracle
+ store
+ (map derivation-input-derivation
+ inputs)
+ #:mode mode)))
+ "Given INPUTS, a list of derivation-inputs, return two values: the list of
+derivation to build, and the list of substitutable items that, together,
+allows INPUTS to be realized.
+
+SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
+by 'substitution-oracle'."
+ (define (built? item)
+ (valid-path? store item))
+
+ (define (input-built? input)
;; In 'check' mode, assume that DRV is not built.
(and (not (and (eqv? mode (build-mode check))
- (eq? drv* drv)))
- (every built? (derivation-output-paths drv* sub-drvs))))
-
- (define (derivation-substitutable-info drv sub-drvs)
- (and (substitutable-derivation? drv)
- (let ((info (filter-map substitutable-info
- (derivation-output-paths drv sub-drvs))))
- (and (= (length info) (length sub-drvs))
+ (member input inputs)))
+ (every built? (derivation-input-output-paths input))))
+
+ (define (input-substitutable-info input)
+ (and (substitutable-derivation? (derivation-input-derivation input))
+ (let* ((items (derivation-input-output-paths input))
+ (info (filter-map substitutable-info items)))
+ (and (= (length info) (length items))
info))))
- (let loop ((drv drv)
- (sub-drvs outputs)
- (build '()) ;list of <derivation-input>
- (substitute '())) ;list of <substitutable>
- (cond ((derivation-built? drv sub-drvs)
- (values build substitute))
- ((derivation-substitutable-info drv sub-drvs)
- =>
- (lambda (substitutables)
- (values build
- (append substitutables substitute))))
- (else
- (let ((build (if (substitutable-derivation? drv)
- build
- (cons (make-derivation-input
- (derivation-file-name drv) sub-drvs)
- build)))
- (inputs (remove (lambda (i)
- (or (member i build) ; XXX: quadratic
- (input-built? i)
- (input-substitutable? i)))
- (derivation-inputs drv))))
- (fold2 loop
- (append inputs build)
- (append (append-map (lambda (input)
- (if (and (not (input-built? input))
- (input-substitutable? input))
- (map substitutable-info
- (derivation-input-output-paths
- input))
- '()))
- (derivation-inputs drv))
- substitute)
- (map (lambda (i)
- (read-derivation-from-file
- (derivation-input-path i)))
- inputs)
- (map derivation-input-sub-derivations inputs)))))))
+ (let loop ((inputs inputs) ;list of <derivation-input>
+ (build '()) ;list of <derivation>
+ (substitute '()) ;list of <substitutable>
+ (visited (set))) ;set of <derivation-input>
+ (match inputs
+ (()
+ (values build substitute))
+ ((input rest ...)
+ (cond ((set-contains? visited input)
+ (loop rest build substitute visited))
+ ((input-built? input)
+ (loop rest build substitute
+ (set-insert input visited)))
+ ((input-substitutable-info input)
+ =>
+ (lambda (substitutables)
+ (loop rest build
+ (append substitutables substitute)
+ (set-insert input visited))))
+ (else
+ (let ((deps (derivation-inputs
+ (derivation-input-derivation input))))
+ (loop (append deps rest)
+ (cons (derivation-input-derivation input) build)
+ substitute
+ (set-insert input visited)))))))))
+
+(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
+ derivation-build-plan
+ (let-values (((build download)
+ (apply derivation-build-plan store
+ (list (derivation-input drv)) rest)))
+ (values (map derivation-input build) download)))
(define (read-derivation drv-port)
"Read the derivation from DRV-PORT and return the corresponding <derivation>
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 93f4cdd8ee..35fb20bab0 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -809,13 +809,13 @@
(equal? (pk 'x content) (pk 'y (call-with-input-file out get-string-all)))
)))))
-(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
+(test-assert "build-expression->derivation and derivation-build-plan"
(let ((drv (build-expression->derivation %store "fail" #f)))
;; The only direct dependency is (%guile-for-build) and it's already
;; built.
- (null? (derivation-prerequisites-to-build %store drv))))
+ (null? (derivation-build-plan %store (derivation-inputs drv)))))
-(test-assert "derivation-prerequisites-to-build when outputs already present"
+(test-assert "derivation-build-plan when outputs already present"
(let* ((builder `(begin ,(random-text) (mkdir %output) #t))
(input-drv (build-expression->derivation %store "input" builder))
(input-path (derivation->output-path input-drv))
@@ -828,9 +828,12 @@
(valid-path? %store output))
(error "things already built" input-drv))
- (and (equal? (map derivation-input-path
- (derivation-prerequisites-to-build %store drv))
- (list (derivation-file-name input-drv)))
+ (and (lset= equal?
+ (map derivation-file-name
+ (derivation-build-plan %store
+ (list (derivation-input drv))))
+ (list (derivation-file-name input-drv)
+ (derivation-file-name drv)))
;; Build DRV and delete its input.
(build-derivations %store (list drv))
@@ -839,9 +842,10 @@
;; Now INPUT-PATH is missing, yet it shouldn't be listed as a
;; prerequisite to build because DRV itself is already built.
- (null? (derivation-prerequisites-to-build %store drv)))))
+ (null? (derivation-build-plan %store
+ (list (derivation-input drv)))))))
-(test-assert "derivation-prerequisites-to-build and substitutes"
+(test-assert "derivation-build-plan and substitutes"
(let* ((store (open-connection))
(drv (build-expression->derivation store "prereq-subst"
(random 1000)))
@@ -853,17 +857,19 @@
(with-derivation-narinfo drv
(let-values (((build download)
- (derivation-prerequisites-to-build store drv))
+ (derivation-build-plan store
+ (list (derivation-input drv))))
((build* download*)
- (derivation-prerequisites-to-build store drv
- #:substitutable-info
- (const #f))))
+ (derivation-build-plan store
+ (list (derivation-input drv))
+ #:substitutable-info
+ (const #f))))
(and (null? build)
(equal? (map substitutable-path download) (list output))
(null? download*)
- (null? build*))))))
+ (equal? (list drv) build*))))))
-(test-assert "derivation-prerequisites-to-build and substitutes, non-substitutable build"
+(test-assert "derivation-build-plan and substitutes, non-substitutable build"
(let* ((store (open-connection))
(drv (build-expression->derivation store "prereq-no-subst"
(random 1000)
@@ -876,16 +882,16 @@
(with-derivation-narinfo drv
(let-values (((build download)
- (derivation-prerequisites-to-build store drv)))
+ (derivation-build-plan store
+ (list (derivation-input drv)))))
;; Despite being available as a substitute, DRV will be built locally
;; due to #:substitutable? #f.
(and (null? download)
(match build
- (((? derivation-input? input))
- (string=? (derivation-input-path input)
- (derivation-file-name drv)))))))))
+ (((= derivation-file-name build))
+ (string=? build (derivation-file-name drv)))))))))
-(test-assert "derivation-prerequisites-to-build and substitutes, local build"
+(test-assert "derivation-build-plan and substitutes, local build"
(with-store store
(let* ((drv (build-expression->derivation store "prereq-subst-local"
(random 1000)
@@ -898,7 +904,8 @@
(with-derivation-narinfo drv
(let-values (((build download)
- (derivation-prerequisites-to-build store drv)))
+ (derivation-build-plan store
+ (list (derivation-input drv)))))
;; #:local-build? is *not* synonymous with #:substitutable?, so we
;; must be able to substitute DRV's output.
;; See <http://bugs.gnu.org/18747>.
@@ -907,7 +914,7 @@
(((= substitutable-path item))
(string=? item (derivation->output-path drv))))))))))
-(test-assert "derivation-prerequisites-to-build in 'check' mode"
+(test-assert "derivation-build-plan in 'check' mode"
(with-store store
(let* ((dep (build-expression->derivation store "dep"
`(begin ,(random-text)
@@ -919,13 +926,13 @@
(delete-paths store (list (derivation->output-path dep)))
;; In 'check' mode, DEP must be rebuilt.
- (and (null? (derivation-prerequisites-to-build store drv))
- (match (derivation-prerequisites-to-build store drv
- #:mode (build-mode
- check))
- ((input)
- (string=? (derivation-input-path input)
- (derivation-file-name dep))))))))
+ (and (null? (derivation-build-plan store
+ (list (derivation-input drv))))
+ (lset= equal?
+ (derivation-build-plan store
+ (list (derivation-input drv))
+ #:mode (build-mode check))
+ (list drv dep))))))
(test-assert "substitution-oracle and #:substitute? #f"
(with-store store