nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2019-06-19 22:05:06 +02:00
parent c89985d91d
commit ba04f80e2e
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 97 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

132
guix/derivations.scm
View File

@ -21,6 +21,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
@ -34,6 +35,7 @@
#:use-module (guix base16) #:use-module (guix base16)
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix combinators) #:use-module (guix combinators)
#:use-module (guix deprecation)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (gcrypt hash) #:use-module (gcrypt hash)
#:use-module (guix base32) #:use-module (guix base32)
@ -50,7 +52,8 @@
derivation-builder-environment-vars derivation-builder-environment-vars
derivation-file-name derivation-file-name
derivation-prerequisites derivation-prerequisites
derivation-prerequisites-to-build derivation-build-plan
derivation-prerequisites-to-build ;deprecated
<derivation-output> <derivation-output>
derivation-output? derivation-output?
@ -61,6 +64,7 @@
<derivation-input> <derivation-input>
derivation-input? derivation-input?
derivation-input
derivation-input-path derivation-input-path
derivation-input-derivation derivation-input-derivation
derivation-input-sub-derivations derivation-input-sub-derivations
@ -341,82 +345,70 @@ substituter many times."
(#f #f) (#f #f)
((key . value) value))))) ((key . value) value)))))
(define* (derivation-prerequisites-to-build store drv (define* (derivation-build-plan store inputs
#:key #:key
(mode (build-mode normal)) (mode (build-mode normal))
(outputs (substitutable-info
(derivation-output-names drv)) (substitution-oracle
(substitutable-info store
(substitution-oracle store (map derivation-input-derivation
(list drv) inputs)
#:mode mode))) #:mode mode)))
"Return two values: the list of derivation-inputs required to build the "Given INPUTS, a list of derivation-inputs, return two values: the list of
OUTPUTS of DRV and not already available in STORE, recursively, and the list derivation to build, and the list of substitutable items that, together,
of required store paths that can be substituted. SUBSTITUTABLE-INFO must be a allows INPUTS to be realized.
one-argument procedure similar to that returned by 'substitution-oracle'."
(define built?
(mlambda (item)
(valid-path? store item)))
(define input-built? SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
(compose (cut any built? <>) derivation-input-output-paths)) by 'substitution-oracle'."
(define (built? item)
(valid-path? store item))
(define input-substitutable? (define (input-built? input)
;; 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)
;; In 'check' mode, assume that DRV is not built. ;; In 'check' mode, assume that DRV is not built.
(and (not (and (eqv? mode (build-mode check)) (and (not (and (eqv? mode (build-mode check))
(eq? drv* drv))) (member input inputs)))
(every built? (derivation-output-paths drv* sub-drvs)))) (every built? (derivation-input-output-paths input))))
(define (derivation-substitutable-info drv sub-drvs) (define (input-substitutable-info input)
(and (substitutable-derivation? drv) (and (substitutable-derivation? (derivation-input-derivation input))
(let ((info (filter-map substitutable-info (let* ((items (derivation-input-output-paths input))
(derivation-output-paths drv sub-drvs)))) (info (filter-map substitutable-info items)))
(and (= (length info) (length sub-drvs)) (and (= (length info) (length items))
info)))) info))))
(let loop ((drv drv) (let loop ((inputs inputs) ;list of <derivation-input>
(sub-drvs outputs) (build '()) ;list of <derivation>
(build '()) ;list of <derivation-input> (substitute '()) ;list of <substitutable>
(substitute '())) ;list of <substitutable> (visited (set))) ;set of <derivation-input>
(cond ((derivation-built? drv sub-drvs) (match inputs
(values build substitute)) (()
((derivation-substitutable-info drv sub-drvs) (values build substitute))
=> ((input rest ...)
(lambda (substitutables) (cond ((set-contains? visited input)
(values build (loop rest build substitute visited))
(append substitutables substitute)))) ((input-built? input)
(else (loop rest build substitute
(let ((build (if (substitutable-derivation? drv) (set-insert input visited)))
build ((input-substitutable-info input)
(cons (make-derivation-input =>
(derivation-file-name drv) sub-drvs) (lambda (substitutables)
build))) (loop rest build
(inputs (remove (lambda (i) (append substitutables substitute)
(or (member i build) ; XXX: quadratic (set-insert input visited))))
(input-built? i) (else
(input-substitutable? i))) (let ((deps (derivation-inputs
(derivation-inputs drv)))) (derivation-input-derivation input))))
(fold2 loop (loop (append deps rest)
(append inputs build) (cons (derivation-input-derivation input) build)
(append (append-map (lambda (input) substitute
(if (and (not (input-built? input)) (set-insert input visited)))))))))
(input-substitutable? input))
(map substitutable-info (define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
(derivation-input-output-paths derivation-build-plan
input)) (let-values (((build download)
'())) (apply derivation-build-plan store
(derivation-inputs drv)) (list (derivation-input drv)) rest)))
substitute) (values (map derivation-input build) download)))
(map (lambda (i)
(read-derivation-from-file
(derivation-input-path i)))
inputs)
(map derivation-input-sub-derivations inputs)))))))
(define (read-derivation drv-port) (define (read-derivation drv-port)
"Read the derivation from DRV-PORT and return the corresponding <derivation> "Read the derivation from DRV-PORT and return the corresponding <derivation>

63
tests/derivations.scm
View File

@ -809,13 +809,13 @@
(equal? (pk 'x content) (pk 'y (call-with-input-file out get-string-all))) (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))) (let ((drv (build-expression->derivation %store "fail" #f)))
;; The only direct dependency is (%guile-for-build) and it's already ;; The only direct dependency is (%guile-for-build) and it's already
;; built. ;; 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)) (let* ((builder `(begin ,(random-text) (mkdir %output) #t))
(input-drv (build-expression->derivation %store "input" builder)) (input-drv (build-expression->derivation %store "input" builder))
(input-path (derivation->output-path input-drv)) (input-path (derivation->output-path input-drv))
@ -828,9 +828,12 @@
(valid-path? %store output)) (valid-path? %store output))
(error "things already built" input-drv)) (error "things already built" input-drv))
(and (equal? (map derivation-input-path (and (lset= equal?
(derivation-prerequisites-to-build %store drv)) (map derivation-file-name
(list (derivation-file-name input-drv))) (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 DRV and delete its input.
(build-derivations %store (list drv)) (build-derivations %store (list drv))
@ -839,9 +842,10 @@
;; Now INPUT-PATH is missing, yet it shouldn't be listed as a ;; Now INPUT-PATH is missing, yet it shouldn't be listed as a
;; prerequisite to build because DRV itself is already built. ;; 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)) (let* ((store (open-connection))
(drv (build-expression->derivation store "prereq-subst" (drv (build-expression->derivation store "prereq-subst"
(random 1000))) (random 1000)))
@ -853,17 +857,19 @@
(with-derivation-narinfo drv (with-derivation-narinfo drv
(let-values (((build download) (let-values (((build download)
(derivation-prerequisites-to-build store drv)) (derivation-build-plan store
(list (derivation-input drv))))
((build* download*) ((build* download*)
(derivation-prerequisites-to-build store drv (derivation-build-plan store
#:substitutable-info (list (derivation-input drv))
(const #f)))) #:substitutable-info
(const #f))))
(and (null? build) (and (null? build)
(equal? (map substitutable-path download) (list output)) (equal? (map substitutable-path download) (list output))
(null? download*) (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)) (let* ((store (open-connection))
(drv (build-expression->derivation store "prereq-no-subst" (drv (build-expression->derivation store "prereq-no-subst"
(random 1000) (random 1000)
@ -876,16 +882,16 @@
(with-derivation-narinfo drv (with-derivation-narinfo drv
(let-values (((build download) (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 ;; Despite being available as a substitute, DRV will be built locally
;; due to #:substitutable? #f. ;; due to #:substitutable? #f.
(and (null? download) (and (null? download)
(match build (match build
(((? derivation-input? input)) (((= derivation-file-name build))
(string=? (derivation-input-path input) (string=? build (derivation-file-name drv)))))))))
(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 (with-store store
(let* ((drv (build-expression->derivation store "prereq-subst-local" (let* ((drv (build-expression->derivation store "prereq-subst-local"
(random 1000) (random 1000)
@ -898,7 +904,8 @@
(with-derivation-narinfo drv (with-derivation-narinfo drv
(let-values (((build download) (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 ;; #:local-build? is *not* synonymous with #:substitutable?, so we
;; must be able to substitute DRV's output. ;; must be able to substitute DRV's output.
;; See <http://bugs.gnu.org/18747>. ;; See <http://bugs.gnu.org/18747>.
@ -907,7 +914,7 @@
(((= substitutable-path item)) (((= substitutable-path item))
(string=? item (derivation->output-path drv)))))))))) (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 (with-store store
(let* ((dep (build-expression->derivation store "dep" (let* ((dep (build-expression->derivation store "dep"
`(begin ,(random-text) `(begin ,(random-text)
@ -919,13 +926,13 @@
(delete-paths store (list (derivation->output-path dep))) (delete-paths store (list (derivation->output-path dep)))
;; In 'check' mode, DEP must be rebuilt. ;; In 'check' mode, DEP must be rebuilt.
(and (null? (derivation-prerequisites-to-build store drv)) (and (null? (derivation-build-plan store
(match (derivation-prerequisites-to-build store drv (list (derivation-input drv))))
#:mode (build-mode (lset= equal?
check)) (derivation-build-plan store
((input) (list (derivation-input drv))
(string=? (derivation-input-path input) #:mode (build-mode check))
(derivation-file-name dep)))))))) (list drv dep))))))
(test-assert "substitution-oracle and #:substitute? #f" (test-assert "substitution-oracle and #:substitute? #f"
(with-store store (with-store store