aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-06-23 11:28:29 +0200
committerLudovic Courtès <ludo@gnu.org>2019-06-27 11:14:41 +0200
commit5cf4b26d52bcea382d98fb4becce89be9ee37b55 (patch)
tree6d2f162534db09910bf9ff103210a7eec6b8eee1
parenta25006198690dc263ce1b13de6733055c6d6eba4 (diff)
downloadguix-5cf4b26d52bcea382d98fb4becce89be9ee37b55.tar
guix-5cf4b26d52bcea382d98fb4becce89be9ee37b55.tar.gz
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>.
-rw-r--r--guix/derivations.scm156
-rw-r--r--tests/derivations.scm10
2 files changed, 95 insertions, 71 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm
index f6e94694fd..5c568f223b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -152,22 +152,28 @@
(recursive? derivation-output-recursive?)) ; Boolean
(define-immutable-record-type <derivation-input>
- (make-derivation-input path sub-derivations)
+ (make-derivation-input drv sub-derivations)
derivation-input?
- (path derivation-input-path) ; store path
+ (drv derivation-input-derivation) ; <derivation>
(sub-derivations derivation-input-sub-derivations)) ; list of strings
-(define (derivation-input-derivation input)
- "Return the <derivation> object INPUT refers to."
- (read-derivation-from-file (derivation-input-path input)))
+
+(define (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
(outputs (derivation-output-names drv)))
"Return a <derivation-input> for the OUTPUTS of DRV."
;; This is a public interface meant to be more convenient than
;; 'make-derivation-input' and giving us more control.
- (make-derivation-input (derivation-file-name drv)
- outputs))
+ (make-derivation-input drv 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>
(lambda (drv port)
@@ -209,8 +215,8 @@ download with a fixed hash (aka. `fetchurl')."
"Return the list of output paths corresponding to INPUT, a
<derivation-input>."
(match input
- (($ <derivation-input> path sub-drvs)
- (map (cut derivation-path->output-path path <>)
+ (($ <derivation-input> drv sub-drvs)
+ (map (cut derivation->output-path drv <>)
sub-drvs))))
(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."
(fold (lambda (input result)
(match input
- (($ <derivation-input> path sub-drvs)
+ (($ <derivation-input> (= derivation-file-name path) sub-drvs)
;; XXX: quadratic
(match (find (match-lambda
- (($ <derivation-input> p s)
+ (($ <derivation-input> (= derivation-file-name p)
+ s)
(string=? p path)))
result)
(#f
(cons input result))
- ((and dup ($ <derivation-input> _ sub-drvs2))
+ ((and dup ($ <derivation-input> drv sub-drvs2))
;; Merge DUP with INPUT.
(let ((sub-drvs (delete-duplicates
(append sub-drvs sub-drvs2))))
- (cons (make-derivation-input path
- (sort sub-drvs string<?))
+ (cons (make-derivation-input drv (sort sub-drvs string<?))
(delq dup result))))))))
'()
inputs))
@@ -254,12 +260,14 @@ result is the set of prerequisites of DRV not already in valid."
(result '())
(input-set (set)))
(let ((inputs (remove (lambda (input)
- (or (set-contains? input-set input)
+ (or (set-contains? input-set
+ (derivation-input-key input))
(cut? input)))
(derivation-inputs drv))))
(fold2 loop
(append inputs result)
- (fold set-insert input-set inputs)
+ (fold set-insert input-set
+ (map derivation-input-key inputs))
(map derivation-input-derivation inputs)))))
(define (offloadable-derivation? drv)
@@ -384,24 +392,25 @@ by 'substitution-oracle'."
(()
(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)))))))))
+ (let ((key (derivation-input-key input)))
+ (cond ((set-contains? visited key)
+ (loop rest build substitute visited))
+ ((input-built? input)
+ (loop rest build substitute
+ (set-insert key visited)))
+ ((input-substitutable-info input)
+ =>
+ (lambda (substitutables)
+ (loop rest build
+ (append substitutables substitute)
+ (set-insert key visited))))
+ (else
+ (let ((deps (derivation-inputs
+ (derivation-input-derivation input))))
+ (loop (append deps rest)
+ (cons (derivation-input-derivation input) build)
+ substitute
+ (set-insert key visited))))))))))
(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
derivation-build-plan
@@ -410,10 +419,15 @@ by 'substitution-oracle'."
(list (derivation-input drv)) rest)))
(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>
-object. Most of the time you'll want to use 'read-derivation-from-file',
-which caches things as appropriate and is thus more efficient."
+object. Call READ-DERIVATION-FROM-FILE to read derivations declared as inputs
+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 ","))
@@ -449,8 +463,9 @@ which caches things as appropriate and is thus more efficient."
(fold-right (lambda (input result)
(match input
((path (sub-drvs ...))
- (cons (make-derivation-input path sub-drvs)
- result))))
+ (let ((drv (read-derivation-from-file path)))
+ (cons (make-derivation-input drv sub-drvs)
+ result)))))
'()
x))
@@ -552,9 +567,15 @@ that form."
(define (write-input input port)
(match input
- (($ <derivation-input> path sub-drvs)
+ (($ <derivation-input> obj sub-drvs)
(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)
(write-string-list sub-drvs)
(display ")" port))))
@@ -645,13 +666,16 @@ name of each input with that input's hash."
(($ <derivation> outputs inputs sources
system builder args env-vars)
(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)))
(make-derivation-input hash sub-drvs))))
inputs)))
(make-derivation outputs
- (sort (coalesce-duplicate-inputs inputs)
- derivation-input<?)
+ (sort inputs
+ (lambda (drv1 drv2)
+ (string<? (derivation-input-derivation drv1)
+ (derivation-input-derivation drv2))))
sources
system builder args env-vars
#f)))))
@@ -807,17 +831,19 @@ derivation. It is kept as-is, uninterpreted, in the derivation."
(define input->derivation-input
(match-lambda
(((? derivation? drv))
- (make-derivation-input (derivation-file-name drv) '("out")))
+ (make-derivation-input drv '("out")))
(((? derivation? drv) sub-drvs ...)
- (make-derivation-input (derivation-file-name drv) sub-drvs))
- (((? direct-store-path? input))
- (make-derivation-input input '("out")))
- (((? direct-store-path? input) sub-drvs ...)
- (make-derivation-input input sub-drvs))
- ((input . _)
- (let ((path (add-to-store store (basename input)
- #t "sha256" input)))
- (make-derivation-input path '())))))
+ (make-derivation-input drv sub-drvs))
+ (_ #f)))
+
+ (define input->source
+ (match-lambda
+ (((? string? input) . _)
+ (if (direct-store-path? input)
+ input
+ (add-to-store store (basename input)
+ #t "sha256" input)))
+ (_ #f)))
;; Note: lists are sorted alphabetically, to conform with the behavior of
;; 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
hash recursive?)))
(sort outputs string<?)))
+ (sources (sort (delete-duplicates
+ (filter-map input->source inputs))
+ string<?))
(inputs (sort (coalesce-duplicate-inputs
- (map input->derivation-input
- (delete-duplicates inputs)))
+ (filter-map input->derivation-input inputs))
derivation-input<?))
(env-vars (sort (env-vars-with-empty-outputs
(user+system-env-vars))
(lambda (e1 e2)
(string<? (car e1) (car e2)))))
- (drv-masked (make-derivation outputs
- (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)
+ (drv-masked (make-derivation outputs inputs sources
system builder args env-vars #f))
(drv (add-output-paths drv-masked)))
(let* ((file (add-data-to-store store (string-append name ".drv")
(derivation->bytevector drv)
- (map derivation-input-path inputs)))
+ (append (map derivation-input-path inputs)
+ sources)))
(drv* (set-field drv (derivation-file-name) file)))
(hash-set! %derivation-cache file drv*)
drv*)))
@@ -920,7 +941,8 @@ recursively."
;; in the format used in 'derivation' calls.
(mlambda (input loop)
(match input
- (($ <derivation-input> path (sub-drvs ...))
+ (($ <derivation-input> (= derivation-file-name path)
+ (sub-drvs ...))
(match (vhash-assoc path mapping)
((_ . (? derivation? replacement))
(cons replacement sub-drvs))
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 35fb20bab0..54fa588969 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -87,9 +87,11 @@
(test-assert "parse & export"
(let* ((f (search-path %load-path "tests/test.drv"))
(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 <>)))
- (d2 (read-derivation (open-bytevector-input-port b2))))
+ (d2 (read-derivation (open-bytevector-input-port b2)
+ identity)))
(and (equal? b1 b2)
(equal? d1 d2))))
@@ -724,7 +726,7 @@
(test-assert "build-expression->derivation and derivation-prerequisites"
(let ((drv (build-expression->derivation %store "fail" #f)))
(any (match-lambda
- (($ <derivation-input> path)
+ (($ <derivation-input> (= derivation-file-name path))
(string=? path (derivation-file-name (%guile-for-build)))))
(derivation-prerequisites drv))))
@@ -741,7 +743,7 @@
(match (derivation-prerequisites c
(cut valid-derivation-input? %store
<>))
- ((($ <derivation-input> file ("out")))
+ ((($ <derivation-input> (= derivation-file-name file) ("out")))
(string=? file (derivation-file-name b)))
(x
(pk 'fail x #f)))))