TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects 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-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* (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.
(define input-built?
(compose (cut any built? <>) derivation-input-output-paths))
SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
by 'substitution-oracle'."
(define (built? item)
(valid-path? store item))
(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 (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))))
(member input inputs)))
(every built? (derivation-input-output-paths input))))
(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))
(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>

63
tests/derivations.scm
View File

@ -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