diff options
| -rw-r--r-- | guix/derivations.scm | 138 | ||||
| -rw-r--r-- | tests/derivations.scm | 63 |
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 |