TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

derivations: <derivation-input> now aggregates a <derivation>. 

Consequently, the whole graph of <derivation> object is readily
available without having to go through 'read-derivation-from-file',
which could have cache misses if the requested <derivation> object had
been GC'd in the meantime.  This is an important property for the
performance of things like 'derivation-build-plan' that traverse the
derivation graph.

* guix/derivations.scm (<derivation-input>): Replace 'path' field by
'derivation'.
(derivation-input-path): Adjust accordingly.
(derivation-input-key): New procedure.
(derivation-input-output-paths): Adjust accordingly.
(coalesce-duplicate-inputs): Likewise.
(derivation-prerequisites): Use 'derivation-input-key' to compute keys
for INPUT-SET.
(derivation-build-plan): Likewise.
(read-derivation): Add optional 'read-derivation-from-file' parameter.
[make-input-drvs]: Call it.
(write-derivation)[write-input]: Adjust to new <derivation-input>.
(derivation/masked-inputs): Likewise, and remove redundant
'coalesce-duplicate-inputs' call.
(derivation)[input->derivation-input]: Change to consider only the
derivation case.  Update call to 'make-derivation-input'.
[input->source]: New procedure.
Separate sources from inputs.
(map-derivation): Adjust to new <derivation-input>.
* tests/derivations.scm ("parse & export"): Pass a second argument to
'read-derivation'.
("build-expression->derivation and derivation-prerequisites")
("derivation-prerequisites and valid-derivation-input?"): Adjust to new
<derivation-input>.
This commit is contained in:
Ludovic Courtès 2019-06-23 11:28:29 +02:00
parent a250061986
commit 5cf4b26d52
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 95 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

156
guix/derivations.scm
View File

@ -152,22 +152,28 @@
(recursive? derivation-output-recursive?)) ; Boolean (recursive? derivation-output-recursive?)) ; Boolean
(define-immutable-record-type <derivation-input> (define-immutable-record-type <derivation-input>
(make-derivation-input path sub-derivations) (make-derivation-input drv sub-derivations)
derivation-input? derivation-input?
(path derivation-input-path) ; store path (drv derivation-input-derivation) ; <derivation>
(sub-derivations derivation-input-sub-derivations)) ; list of strings (sub-derivations derivation-input-sub-derivations)) ; list of strings
(define (derivation-input-derivation input)
"Return the <derivation> object INPUT refers to." (define (derivation-input-path input)
(read-derivation-from-file (derivation-input-path input))) "Return the file name of the derivation INPUT refers to."
(derivation-file-name (derivation-input-derivation input)))
(define* (derivation-input drv #:optional (define* (derivation-input drv #:optional
(outputs (derivation-output-names drv))) (outputs (derivation-output-names drv)))
"Return a <derivation-input> for the OUTPUTS of DRV." "Return a <derivation-input> for the OUTPUTS of DRV."
;; This is a public interface meant to be more convenient than ;; This is a public interface meant to be more convenient than
;; 'make-derivation-input' and giving us more control. ;; 'make-derivation-input' and giving us more control.
(make-derivation-input (derivation-file-name drv) (make-derivation-input drv outputs))
outputs))
(define (derivation-input-key input)
"Return an object for which 'equal?' and 'hash' are constant-time, and which
can thus be used as a key for INPUT in lookup tables."
(cons (derivation-input-path input)
(derivation-input-sub-derivations input)))
(set-record-type-printer! <derivation> (set-record-type-printer! <derivation>
(lambda (drv port) (lambda (drv port)
@ -209,8 +215,8 @@ download with a fixed hash (aka. `fetchurl')."
"Return the list of output paths corresponding to INPUT, a "Return the list of output paths corresponding to INPUT, a
<derivation-input>." <derivation-input>."
(match input (match input
(($ <derivation-input> path sub-drvs) (($ <derivation-input> drv sub-drvs)
(map (cut derivation-path->output-path path <>) (map (cut derivation->output-path drv <>)
sub-drvs)))) sub-drvs))))
(define (valid-derivation-input? store input) (define (valid-derivation-input? store input)
@ -225,20 +231,20 @@ they are coalesced, with their sub-derivations merged. This is needed because
Nix itself keeps only one of them." Nix itself keeps only one of them."
(fold (lambda (input result) (fold (lambda (input result)
(match input (match input
(($ <derivation-input> path sub-drvs) (($ <derivation-input> (= derivation-file-name path) sub-drvs)
;; XXX: quadratic ;; XXX: quadratic
(match (find (match-lambda (match (find (match-lambda
(($ <derivation-input> p s) (($ <derivation-input> (= derivation-file-name p)
s)
(string=? p path))) (string=? p path)))
result) result)
(#f (#f
(cons input result)) (cons input result))
((and dup ($ <derivation-input> _ sub-drvs2)) ((and dup ($ <derivation-input> drv sub-drvs2))
;; Merge DUP with INPUT. ;; Merge DUP with INPUT.
(let ((sub-drvs (delete-duplicates (let ((sub-drvs (delete-duplicates
(append sub-drvs sub-drvs2)))) (append sub-drvs sub-drvs2))))
(cons (make-derivation-input path (cons (make-derivation-input drv (sort sub-drvs string<?))
(sort sub-drvs string<?))
(delq dup result)))))))) (delq dup result))))))))
'() '()
inputs)) inputs))
@ -254,12 +260,14 @@ result is the set of prerequisites of DRV not already in valid."
(result '()) (result '())
(input-set (set))) (input-set (set)))
(let ((inputs (remove (lambda (input) (let ((inputs (remove (lambda (input)
(or (set-contains? input-set input) (or (set-contains? input-set
(derivation-input-key input))
(cut? input))) (cut? input)))
(derivation-inputs drv)))) (derivation-inputs drv))))
(fold2 loop (fold2 loop
(append inputs result) (append inputs result)
(fold set-insert input-set inputs) (fold set-insert input-set
(map derivation-input-key inputs))
(map derivation-input-derivation inputs))))) (map derivation-input-derivation inputs)))))
(define (offloadable-derivation? drv) (define (offloadable-derivation? drv)
@ -384,24 +392,25 @@ by 'substitution-oracle'."
(() (()
(values build substitute)) (values build substitute))
((input rest ...) ((input rest ...)
(cond ((set-contains? visited input) (let ((key (derivation-input-key input)))
(loop rest build substitute visited)) (cond ((set-contains? visited key)
((input-built? input) (loop rest build substitute visited))
(loop rest build substitute ((input-built? input)
(set-insert input visited))) (loop rest build substitute
((input-substitutable-info input) (set-insert key visited)))
=> ((input-substitutable-info input)
(lambda (substitutables) =>
(loop rest build (lambda (substitutables)
(append substitutables substitute) (loop rest build
(set-insert input visited)))) (append substitutables substitute)
(else (set-insert key visited))))
(let ((deps (derivation-inputs (else
(derivation-input-derivation input)))) (let ((deps (derivation-inputs
(loop (append deps rest) (derivation-input-derivation input))))
(cons (derivation-input-derivation input) build) (loop (append deps rest)
substitute (cons (derivation-input-derivation input) build)
(set-insert input visited))))))))) substitute
(set-insert key visited))))))))))
(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest) (define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
derivation-build-plan derivation-build-plan
@ -410,10 +419,15 @@ by 'substitution-oracle'."
(list (derivation-input drv)) rest))) (list (derivation-input drv)) rest)))
(values (map derivation-input build) download))) (values (map derivation-input build) download)))
(define (read-derivation drv-port) (define* (read-derivation drv-port
#:optional (read-derivation-from-file
read-derivation-from-file))
"Read the derivation from DRV-PORT and return the corresponding <derivation> "Read the derivation from DRV-PORT and return the corresponding <derivation>
object. Most of the time you'll want to use 'read-derivation-from-file', object. Call READ-DERIVATION-FROM-FILE to read derivations declared as inputs
which caches things as appropriate and is thus more efficient." of the derivation being parsed.
Most of the time you'll want to use 'read-derivation-from-file', which caches
things as appropriate and is thus more efficient."
(define comma (string->symbol ",")) (define comma (string->symbol ","))
@ -449,8 +463,9 @@ which caches things as appropriate and is thus more efficient."
(fold-right (lambda (input result) (fold-right (lambda (input result)
(match input (match input
((path (sub-drvs ...)) ((path (sub-drvs ...))
(cons (make-derivation-input path sub-drvs) (let ((drv (read-derivation-from-file path)))
result)))) (cons (make-derivation-input drv sub-drvs)
result)))))
'() '()
x)) x))
@ -552,9 +567,15 @@ that form."
(define (write-input input port) (define (write-input input port)
(match input (match input
(($ <derivation-input> path sub-drvs) (($ <derivation-input> obj sub-drvs)
(display "(\"" port) (display "(\"" port)
(display path port)
;; 'derivation/masked-inputs' produces objects that contain a string
;; instead of a <derivation>, so we need to account for that.
(display (if (derivation? obj)
(derivation-file-name obj)
obj)
port)
(display "\"," port) (display "\"," port)
(write-string-list sub-drvs) (write-string-list sub-drvs)
(display ")" port)))) (display ")" port))))
@ -645,13 +666,16 @@ name of each input with that input's hash."
(($ <derivation> outputs inputs sources (($ <derivation> outputs inputs sources
system builder args env-vars) system builder args env-vars)
(let ((inputs (map (match-lambda (let ((inputs (map (match-lambda
(($ <derivation-input> path sub-drvs) (($ <derivation-input> (= derivation-file-name path)
sub-drvs)
(let ((hash (derivation-path->base16-hash path))) (let ((hash (derivation-path->base16-hash path)))
(make-derivation-input hash sub-drvs)))) (make-derivation-input hash sub-drvs))))
inputs))) inputs)))
(make-derivation outputs (make-derivation outputs
(sort (coalesce-duplicate-inputs inputs) (sort inputs
derivation-input<?) (lambda (drv1 drv2)
(string<? (derivation-input-derivation drv1)
(derivation-input-derivation drv2))))
sources sources
system builder args env-vars system builder args env-vars
#f))))) #f)))))
@ -807,17 +831,19 @@ derivation. It is kept as-is, uninterpreted, in the derivation."
(define input->derivation-input (define input->derivation-input
(match-lambda (match-lambda
(((? derivation? drv)) (((? derivation? drv))
(make-derivation-input (derivation-file-name drv) '("out"))) (make-derivation-input drv '("out")))
(((? derivation? drv) sub-drvs ...) (((? derivation? drv) sub-drvs ...)
(make-derivation-input (derivation-file-name drv) sub-drvs)) (make-derivation-input drv sub-drvs))
(((? direct-store-path? input)) (_ #f)))
(make-derivation-input input '("out")))
(((? direct-store-path? input) sub-drvs ...) (define input->source
(make-derivation-input input sub-drvs)) (match-lambda
((input . _) (((? string? input) . _)
(let ((path (add-to-store store (basename input) (if (direct-store-path? input)
#t "sha256" input))) input
(make-derivation-input path '()))))) (add-to-store store (basename input)
#t "sha256" input)))
(_ #f)))
;; Note: lists are sorted alphabetically, to conform with the behavior of ;; Note: lists are sorted alphabetically, to conform with the behavior of
;; C++ `std::map' in Nix itself. ;; C++ `std::map' in Nix itself.
@ -828,29 +854,24 @@ derivation. It is kept as-is, uninterpreted, in the derivation."
(make-derivation-output "" hash-algo (make-derivation-output "" hash-algo
hash recursive?))) hash recursive?)))
(sort outputs string<?))) (sort outputs string<?)))
(sources (sort (delete-duplicates
(filter-map input->source inputs))
string<?))
(inputs (sort (coalesce-duplicate-inputs (inputs (sort (coalesce-duplicate-inputs
(map input->derivation-input (filter-map input->derivation-input inputs))
(delete-duplicates inputs)))
derivation-input<?)) derivation-input<?))
(env-vars (sort (env-vars-with-empty-outputs (env-vars (sort (env-vars-with-empty-outputs
(user+system-env-vars)) (user+system-env-vars))
(lambda (e1 e2) (lambda (e1 e2)
(string<? (car e1) (car e2))))) (string<? (car e1) (car e2)))))
(drv-masked (make-derivation outputs (drv-masked (make-derivation outputs inputs sources
(filter (compose derivation-path?
derivation-input-path)
inputs)
(filter-map (lambda (i)
(let ((p (derivation-input-path i)))
(and (not (derivation-path? p))
p)))
inputs)
system builder args env-vars #f)) system builder args env-vars #f))
(drv (add-output-paths drv-masked))) (drv (add-output-paths drv-masked)))
(let* ((file (add-data-to-store store (string-append name ".drv") (let* ((file (add-data-to-store store (string-append name ".drv")
(derivation->bytevector drv) (derivation->bytevector drv)
(map derivation-input-path inputs))) (append (map derivation-input-path inputs)
sources)))
(drv* (set-field drv (derivation-file-name) file))) (drv* (set-field drv (derivation-file-name) file)))
(hash-set! %derivation-cache file drv*) (hash-set! %derivation-cache file drv*)
drv*))) drv*)))
@ -920,7 +941,8 @@ recursively."
;; in the format used in 'derivation' calls. ;; in the format used in 'derivation' calls.
(mlambda (input loop) (mlambda (input loop)
(match input (match input
(($ <derivation-input> path (sub-drvs ...)) (($ <derivation-input> (= derivation-file-name path)
(sub-drvs ...))
(match (vhash-assoc path mapping) (match (vhash-assoc path mapping)
((_ . (? derivation? replacement)) ((_ . (? derivation? replacement))
(cons replacement sub-drvs)) (cons replacement sub-drvs))

10
tests/derivations.scm
View File

@ -87,9 +87,11 @@
(test-assert "parse & export" (test-assert "parse & export"
(let* ((f (search-path %load-path "tests/test.drv")) (let* ((f (search-path %load-path "tests/test.drv"))
(b1 (call-with-input-file f get-bytevector-all)) (b1 (call-with-input-file f get-bytevector-all))
(d1 (read-derivation (open-bytevector-input-port b1))) (d1 (read-derivation (open-bytevector-input-port b1)
identity))
(b2 (call-with-bytevector-output-port (cut write-derivation d1 <>))) (b2 (call-with-bytevector-output-port (cut write-derivation d1 <>)))
(d2 (read-derivation (open-bytevector-input-port b2)))) (d2 (read-derivation (open-bytevector-input-port b2)
identity)))
(and (equal? b1 b2) (and (equal? b1 b2)
(equal? d1 d2)))) (equal? d1 d2))))
@ -724,7 +726,7 @@
(test-assert "build-expression->derivation and derivation-prerequisites" (test-assert "build-expression->derivation and derivation-prerequisites"
(let ((drv (build-expression->derivation %store "fail" #f))) (let ((drv (build-expression->derivation %store "fail" #f)))
(any (match-lambda (any (match-lambda
(($ <derivation-input> path) (($ <derivation-input> (= derivation-file-name path))
(string=? path (derivation-file-name (%guile-for-build))))) (string=? path (derivation-file-name (%guile-for-build)))))
(derivation-prerequisites drv)))) (derivation-prerequisites drv))))
@ -741,7 +743,7 @@
(match (derivation-prerequisites c (match (derivation-prerequisites c
(cut valid-derivation-input? %store (cut valid-derivation-input? %store
<>)) <>))
((($ <derivation-input> file ("out"))) ((($ <derivation-input> (= derivation-file-name file) ("out")))
(string=? file (derivation-file-name b))) (string=? file (derivation-file-name b)))
(x (x
(pk 'fail x #f))))) (pk 'fail x #f)))))