That makes ‘derivation-build-plan’ directly usable in cases where one
wants to sequentially build derivations one by one, or to report builds
in the right order in the user interface.
* guix/derivations.scm (derivation-build-plan): Wrap ‘loop’ in
‘traverse’. Perform a depth-first traversal. Return the list of builds
in topological order.
* tests/derivations.scm ("derivation-build-plan, topological ordering"):
New test.
Change-Id: I7cd9083f42c4381b4213794a40dbb5b234df966d
---
guix/derivations.scm | 74 +++++++++++++++++++++++++------------------
tests/derivations.scm | 31 ++++++++++++++++--
2 files changed, 72 insertions(+), 33 deletions(-)
Toggle diff (149 lines)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index a91c1ae984..bef98cd26a 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -401,8 +401,8 @@ (define* (derivation-build-plan store inputs
(substitution-oracle
store inputs #:mode mode)))
"Given INPUTS, a list of derivation-inputs, return two values: the list of
-derivations to build, and the list of substitutable items that, together,
-allow INPUTS to be realized.
+derivations to build, in topological order, and the list of substitutable
+items that, together, allow INPUTS to be realized.
SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
by 'substitution-oracle'."
@@ -422,36 +422,48 @@ (define* (derivation-build-plan store inputs
(and (= (length info) (length items))
info))))
- (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 ...)
- (let ((key (derivation-input-key input))
- (deps (derivation-inputs
- (derivation-input-derivation 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 (append (dependencies-of-substitutables substitutables
+ (define (traverse)
+ ;; Perform a depth-first traversal.
+ (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 visited build substitute))
+ ((input rest ...)
+ (let ((key (derivation-input-key input))
+ (deps (derivation-inputs
+ (derivation-input-derivation 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)
+ (call-with-values
+ (lambda ()
+ (loop (dependencies-of-substitutables substitutables
deps)
- rest)
- build
- (append substitutables substitute)
- (set-insert key visited))))
- (else
- (loop (append deps rest)
- (cons (derivation-input-derivation input) build)
- substitute
- (set-insert key visited)))))))))
+ build
+ (append substitutables substitute)
+ (set-insert key visited)))
+ (lambda (visited build substitute)
+ (loop rest build substitute visited)))))
+ (else
+ (call-with-values
+ (lambda ()
+ (loop deps build substitute (set-insert key visited)))
+ (lambda (visited build substitute)
+ (loop rest
+ (cons (derivation-input-derivation input) build)
+ substitute
+ visited))))))))))
+
+ (call-with-values traverse
+ (lambda (_ build substitute)
+ (values (reverse! build) substitute))))
(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
derivation-build-plan
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 0e87778981..efcd21f324 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,7 +29,8 @@ (define-module (test-derivations)
#:use-module (guix tests git)
#:use-module (guix tests http)
#:use-module ((guix packages) #:select (package-derivation base32))
- #:use-module ((guix build utils) #:select (executable-file?))
+ #:use-module ((guix build utils)
+ #:select (executable-file? strip-store-file-name))
#:use-module ((guix hash) #:select (file-hash*))
#:use-module ((git oid) #:select (oid->string))
#:use-module ((git reference) #:select (reference-name->oid))
@@ -1157,6 +1158,32 @@ (define %coreutils
#:mode (build-mode check))
(list drv dep))))))
+(test-equal "derivation-build-plan, topological ordering"
+ (make-list 5 '("0.drv" "1.drv" "2.drv" "3.drv" "4.drv"))
+ (with-store store
+ (define (test _)
+ (let* ((simple-derivation
+ (lambda (name . deps)
+ (build-expression->derivation
+ store name
+ `(begin ,(random-text) (mkdir %output))
+ #:inputs (map (lambda (n dep)
+ (list (number->string n) dep))
+ (iota (length deps))
+ deps))))
+ (drv0 (simple-derivation "0"))
+ (drv1 (simple-derivation "1" drv0))
+ (drv2 (simple-derivation "2" drv1))
+ (drv3 (simple-derivation "3" drv2 drv0))
+ (drv4 (simple-derivation "4" drv3 drv1)))
+ (map (compose strip-store-file-name derivation-file-name)
+ (derivation-build-plan store (list (derivation-input drv4))))))
+
+ ;; This is probabilistic: if the traversal is buggy, it may or may not
+ ;; produce the wrong ordering, depending on a variety of actors. Thus,
+ ;; try multiple times.
+ (map test (iota 5))))
+
(test-assert "derivation-input-fold"
(let* ((builder (add-text-to-store %store "my-builder.sh"
"echo hello, world > \"$out\"\n"
--
2.46.0
