* [bug#36351] [PATCH 02/10] derivations: Rewrite and replace 'derivations-prerequisites-to-build'.
2019-06-24 12:22 ` [bug#36351] [PATCH 01/10] derivations: Add 'derivation-input' Ludovic Courtès
@ 2019-06-24 12:22 ` Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 03/10] ui: 'show-what-to-build' uses 'derivation-build-plan' Ludovic Courtès
` (7 subsequent siblings)
8 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-06-24 12:22 UTC (permalink / raw)
To: 36351
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.
---
guix/derivations.scm | 132 ++++++++++++++++++++----------------------
tests/derivations.scm | 63 +++++++++++---------
2 files changed, 97 insertions(+), 98 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* (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>
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
--
2.22.0
^ permalink raw reply related [flat|nested] 12+ messages in thread* [bug#36351] [PATCH 03/10] ui: 'show-what-to-build' uses 'derivation-build-plan'.
2019-06-24 12:22 ` [bug#36351] [PATCH 01/10] derivations: Add 'derivation-input' Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 02/10] derivations: Rewrite and replace 'derivations-prerequisites-to-build' Ludovic Courtès
@ 2019-06-24 12:22 ` Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 04/10] graph: Use 'derivation-input-derivation' Ludovic Courtès
` (6 subsequent siblings)
8 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-06-24 12:22 UTC (permalink / raw)
To: 36351
* guix/ui.scm (show-what-to-build)[build-or-substitutable?]: Remove.
Use 'derivation-build-plan' instead of
'derivation-prerequisites-to-build', passing it all of DRV at once, and
remove 'fold2' shenanigans and postprocessing of BUILD.
---
guix/ui.scm | 32 +++++++-------------------------
1 file changed, 7 insertions(+), 25 deletions(-)
diff --git a/guix/ui.scm b/guix/ui.scm
index 0b4fe144b6..3c67fbaa24 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -41,7 +41,6 @@
#:use-module (guix packages)
#:use-module (guix profiles)
#:use-module (guix derivations)
- #:use-module (guix combinators)
#:use-module (guix build-system)
#:use-module (guix serialization)
#:use-module ((guix licenses) #:select (license? license-name))
@@ -820,29 +819,12 @@ report what is prerequisites are available for download."
(substitution-oracle store drv #:mode mode)
(const #f)))
- (define (built-or-substitutable? drv)
- (or (null? (derivation-outputs drv))
- (let ((out (derivation->output-path drv))) ;XXX: assume "out" exists
- (or (valid-path? store out)
- (substitutable-info out)))))
-
(let*-values (((build download)
- (fold2 (lambda (drv build download)
- (let-values (((b d)
- (derivation-prerequisites-to-build
- store drv
- #:mode mode
- #:substitutable-info
- substitutable-info)))
- (values (append b build)
- (append d download))))
- '() '()
- drv))
- ((build) ; add the DRV themselves
- (delete-duplicates
- (append (map derivation-file-name
- (remove built-or-substitutable? drv))
- (map derivation-input-path build))))
+ (derivation-build-plan store
+ (map derivation-input drv)
+ #:mode mode
+ #:substitutable-info
+ substitutable-info))
((download) ; add the references of DOWNLOAD
(if use-substitutes?
(delete-duplicates
@@ -856,8 +838,8 @@ report what is prerequisites are available for download."
download))))
download))
((graft hook build)
- (match (fold (lambda (file acc)
- (let ((drv (read-derivation-from-file file)))
+ (match (fold (lambda (drv acc)
+ (let ((file (derivation-file-name drv)))
(match acc
((#:graft graft #:hook hook #:build build)
(cond
--
2.22.0
^ permalink raw reply related [flat|nested] 12+ messages in thread* [bug#36351] [PATCH 04/10] graph: Use 'derivation-input-derivation'.
2019-06-24 12:22 ` [bug#36351] [PATCH 01/10] derivations: Add 'derivation-input' Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 02/10] derivations: Rewrite and replace 'derivations-prerequisites-to-build' Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 03/10] ui: 'show-what-to-build' uses 'derivation-build-plan' Ludovic Courtès
@ 2019-06-24 12:22 ` Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 05/10] derivations: <derivation-input> now aggregates a <derivation> Ludovic Courtès
` (5 subsequent siblings)
8 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-06-24 12:22 UTC (permalink / raw)
To: 36351
* guix/scripts/graph.scm (derivation-dependencies): Use
'derivation-input-derivation'.
---
guix/scripts/graph.scm | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 8fe81ad64b..2e14857f1e 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -254,8 +254,7 @@ GNU-BUILD-SYSTEM have zero dependencies."
"Return the <derivation> objects and store items corresponding to the
dependencies of OBJ, a <derivation> or store item."
(if (derivation? obj)
- (append (map (compose read-derivation-from-file derivation-input-path)
- (derivation-inputs obj))
+ (append (map derivation-input-derivation (derivation-inputs obj))
(derivation-sources obj))
'()))
--
2.22.0
^ permalink raw reply related [flat|nested] 12+ messages in thread* [bug#36351] [PATCH 05/10] derivations: <derivation-input> now aggregates a <derivation>.
2019-06-24 12:22 ` [bug#36351] [PATCH 01/10] derivations: Add 'derivation-input' Ludovic Courtès
` (2 preceding siblings ...)
2019-06-24 12:22 ` [bug#36351] [PATCH 04/10] graph: Use 'derivation-input-derivation' Ludovic Courtès
@ 2019-06-24 12:22 ` Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 06/10] derivations: 'derivation' preserves pointer equality Ludovic Courtès
` (4 subsequent siblings)
8 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-06-24 12:22 UTC (permalink / raw)
To: 36351
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>.
---
guix/derivations.scm | 156 ++++++++++++++++++++++++------------------
tests/derivations.scm | 10 +--
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)))))
--
2.22.0
^ permalink raw reply related [flat|nested] 12+ messages in thread* [bug#36351] [PATCH 06/10] derivations: 'derivation' preserves pointer equality.
2019-06-24 12:22 ` [bug#36351] [PATCH 01/10] derivations: Add 'derivation-input' Ludovic Courtès
` (3 preceding siblings ...)
2019-06-24 12:22 ` [bug#36351] [PATCH 05/10] derivations: <derivation-input> now aggregates a <derivation> Ludovic Courtès
@ 2019-06-24 12:22 ` Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 07/10] derivations: 'build-derivations' can be passed derivation inputs Ludovic Courtès
` (3 subsequent siblings)
8 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-06-24 12:22 UTC (permalink / raw)
To: 36351
* guix/derivations.scm (derivation): Check if FILE is already in
%DERIVATION-CACHE and return it if it is.
---
guix/derivations.scm | 8 ++++++--
1 file changed, 6 insertions(+), 2 deletions(-)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 5c568f223b..403e86749b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -873,8 +873,12 @@ derivation. It is kept as-is, uninterpreted, in the derivation."
(append (map derivation-input-path inputs)
sources)))
(drv* (set-field drv (derivation-file-name) file)))
- (hash-set! %derivation-cache file drv*)
- drv*)))
+ ;; Preserve pointer equality. This improves the performance of
+ ;; 'eq?'-memoization on derivations.
+ (or (hash-ref %derivation-cache file)
+ (begin
+ (hash-set! %derivation-cache file drv*)
+ drv*)))))
(define (invalidate-derivation-caches!)
"Invalidate internal derivation caches. This is mostly useful for
--
2.22.0
^ permalink raw reply related [flat|nested] 12+ messages in thread* [bug#36351] [PATCH 07/10] derivations: 'build-derivations' can be passed derivation inputs.
2019-06-24 12:22 ` [bug#36351] [PATCH 01/10] derivations: Add 'derivation-input' Ludovic Courtès
` (4 preceding siblings ...)
2019-06-24 12:22 ` [bug#36351] [PATCH 06/10] derivations: 'derivation' preserves pointer equality Ludovic Courtès
@ 2019-06-24 12:22 ` Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 08/10] packages: 'specification->package+output' distinguishes "no output specified" Ludovic Courtès
` (2 subsequent siblings)
8 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-06-24 12:22 UTC (permalink / raw)
To: 36351
* guix/derivations.scm (build-derivations): Accept <derivation-input>
records among DERIVATIONS.
* tests/derivations.scm ("build-derivations with specific output"): Test
it.
---
guix/derivations.scm | 5 +++++
tests/derivations.scm | 7 +++++--
2 files changed, 10 insertions(+), 2 deletions(-)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 403e86749b..433b4551a5 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1016,6 +1016,11 @@ derivation/output pairs, using the specified MODE."
(build-things store (map (match-lambda
((? derivation? drv)
(derivation-file-name drv))
+ ((? derivation-input? input)
+ (cons (derivation-input-path input)
+ (string-join
+ (derivation-input-sub-derivations input)
+ ",")))
((? string? file) file)
(((? derivation? drv) . output)
(cons (derivation-file-name drv)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 54fa588969..d173a78906 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -807,9 +807,12 @@
;; Ask for nothing but the "out" output of DRV.
(build-derivations store `((,drv . "out")))
+ ;; Synonymous:
+ (build-derivations store (list (derivation-input drv '("out"))))
+
(valid-path? store out)
- (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-build-plan"
(let ((drv (build-expression->derivation %store "fail" #f)))
--
2.22.0
^ permalink raw reply related [flat|nested] 12+ messages in thread* [bug#36351] [PATCH 08/10] packages: 'specification->package+output' distinguishes "no output specified".
2019-06-24 12:22 ` [bug#36351] [PATCH 01/10] derivations: Add 'derivation-input' Ludovic Courtès
` (5 preceding siblings ...)
2019-06-24 12:22 ` [bug#36351] [PATCH 07/10] derivations: 'build-derivations' can be passed derivation inputs Ludovic Courtès
@ 2019-06-24 12:22 ` Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 09/10] ui: 'show-what-to-build' accepts derivation inputs Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 10/10] ui: 'show-derivation-outputs' accepts <derivation-input> records Ludovic Courtès
8 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-06-24 12:22 UTC (permalink / raw)
To: 36351
Until now the caller couldn't tell the different between a spec like
"foo:out" and one like "foo". This change allows users to distinguish
between these two cases.
* gnu/packages.scm (specification->package+output): Disable output
membership test when OUTPUT = #f and SUB-DRV = #f.
* tests/packages.scm ("specification->package+output")
("specification->package+output invalid output")
("specification->package+output no default output")
("specification->package+output invalid output, no default"): New tests.
---
gnu/packages.scm | 8 ++++++--
tests/packages.scm | 32 ++++++++++++++++++++++++++++++++
2 files changed, 38 insertions(+), 2 deletions(-)
diff --git a/gnu/packages.scm b/gnu/packages.scm
index 48390575ba..acb247e114 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -534,14 +534,18 @@ optionally contain a version number and an output name, as in these examples:
guile@2.0.9:debug
If SPEC does not specify a version number, return the preferred newest
-version; if SPEC does not specify an output, return OUTPUT."
+version; if SPEC does not specify an output, return OUTPUT.
+
+When OUTPUT is false and SPEC does not specify any output, return #f as the
+output."
(let-values (((name version sub-drv)
(package-specification->name+version+output spec output)))
(match (%find-package spec name version)
(#f
(values #f #f))
(package
- (if (member sub-drv (package-outputs package))
+ (if (or (and (not output) (not sub-drv))
+ (member sub-drv (package-outputs package)))
(values package sub-drv)
(leave (G_ "package `~a' lacks output `~a'~%")
(package-full-name package)
diff --git a/tests/packages.scm b/tests/packages.scm
index 613b2f1221..836d446657 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1227,6 +1227,38 @@
(lambda (key . args)
key)))
+(test-equal "specification->package+output"
+ `((,coreutils "out") (,coreutils "debug"))
+ (list (call-with-values (lambda ()
+ (specification->package+output "coreutils"))
+ list)
+ (call-with-values (lambda ()
+ (specification->package+output "coreutils:debug"))
+ list)))
+
+(test-equal "specification->package+output invalid output"
+ 'error
+ (catch 'quit
+ (lambda ()
+ (specification->package+output "coreutils:does-not-exist"))
+ (lambda _
+ 'error)))
+
+(test-equal "specification->package+output no default output"
+ `(,coreutils #f)
+ (call-with-values
+ (lambda ()
+ (specification->package+output "coreutils" #f))
+ list))
+
+(test-equal "specification->package+output invalid output, no default"
+ 'error
+ (catch 'quit
+ (lambda ()
+ (specification->package+output "coreutils:does-not-exist" #f))
+ (lambda _
+ 'error)))
+
(test-equal "find-package-locations"
(map (lambda (package)
(cons (package-version package)
--
2.22.0
^ permalink raw reply related [flat|nested] 12+ messages in thread* [bug#36351] [PATCH 09/10] ui: 'show-what-to-build' accepts derivation inputs.
2019-06-24 12:22 ` [bug#36351] [PATCH 01/10] derivations: Add 'derivation-input' Ludovic Courtès
` (6 preceding siblings ...)
2019-06-24 12:22 ` [bug#36351] [PATCH 08/10] packages: 'specification->package+output' distinguishes "no output specified" Ludovic Courtès
@ 2019-06-24 12:22 ` Ludovic Courtès
2019-06-24 12:22 ` [bug#36351] [PATCH 10/10] ui: 'show-derivation-outputs' accepts <derivation-input> records Ludovic Courtès
8 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-06-24 12:22 UTC (permalink / raw)
To: 36351
This is a followup to f8a9f99cd602ce1dc5307cb0c21ae718ad8796bb.
* guix/ui.scm (show-what-to-build)[inputs]: New variables.
[substitutable-info]: Build the derivation list from INPUTS.
Pass INPUTS to 'derivation-build-plan'.
---
guix/ui.scm | 20 ++++++++++++++------
1 file changed, 14 insertions(+), 6 deletions(-)
diff --git a/guix/ui.scm b/guix/ui.scm
index 3c67fbaa24..bdcae34ee2 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -808,20 +808,28 @@ warning."
#:key dry-run? (use-substitutes? #t)
(mode (build-mode normal)))
"Show what will or would (depending on DRY-RUN?) be built in realizing the
-derivations listed in DRV using MODE, a 'build-mode' value. Return #t if
-there's something to build, #f otherwise. When USE-SUBSTITUTES?, check and
-report what is prerequisites are available for download."
+derivations listed in DRV using MODE, a 'build-mode' value. The elements of
+DRV can be either derivations or derivation inputs.
+
+Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?,
+check and report what is prerequisites are available for download."
+ (define inputs
+ (map (match-lambda
+ ((? derivation? drv) (derivation-input drv))
+ ((? derivation-input? input) input))
+ drv))
+
(define substitutable-info
;; Call 'substitutation-oracle' upfront so we don't end up launching the
;; substituter many times. This makes a big difference, especially when
;; DRV is a long list as is the case with 'guix environment'.
(if use-substitutes?
- (substitution-oracle store drv #:mode mode)
+ (substitution-oracle store (map derivation-input-derivation inputs)
+ #:mode mode)
(const #f)))
(let*-values (((build download)
- (derivation-build-plan store
- (map derivation-input drv)
+ (derivation-build-plan store inputs
#:mode mode
#:substitutable-info
substitutable-info))
--
2.22.0
^ permalink raw reply related [flat|nested] 12+ messages in thread* [bug#36351] [PATCH 10/10] ui: 'show-derivation-outputs' accepts <derivation-input> records.
2019-06-24 12:22 ` [bug#36351] [PATCH 01/10] derivations: Add 'derivation-input' Ludovic Courtès
` (7 preceding siblings ...)
2019-06-24 12:22 ` [bug#36351] [PATCH 09/10] ui: 'show-what-to-build' accepts derivation inputs Ludovic Courtès
@ 2019-06-24 12:22 ` Ludovic Courtès
8 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2019-06-24 12:22 UTC (permalink / raw)
To: 36351
* guix/ui.scm (show-derivation-outputs): Handle <derivation-input>
records.
---
guix/ui.scm | 19 +++++++++++++------
1 file changed, 13 insertions(+), 6 deletions(-)
diff --git a/guix/ui.scm b/guix/ui.scm
index bdcae34ee2..b6985adf23 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -773,12 +773,19 @@ error."
str))))
(define (show-derivation-outputs derivation)
- "Show the output file names of DERIVATION."
- (format #t "~{~a~%~}"
- (map (match-lambda
- ((out-name . out)
- (derivation->output-path derivation out-name)))
- (derivation-outputs derivation))))
+ "Show the output file names of DERIVATION, which can be a derivation or a
+derivation input."
+ (define (show-outputs derivation outputs)
+ (format #t "~{~a~%~}"
+ (map (cut derivation->output-path derivation <>)
+ outputs)))
+
+ (match derivation
+ ((? derivation?)
+ (show-outputs derivation (derivation-output-names derivation)))
+ ((? derivation-input? input)
+ (show-outputs (derivation-input-derivation input)
+ (derivation-input-sub-derivations input)))))
(define* (check-available-space need
#:optional (directory (%store-prefix)))
--
2.22.0
^ permalink raw reply related [flat|nested] 12+ messages in thread