mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 13:36:36 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

derivations: ‘derivation-build-plan’ returns builds in topological order.

Browse source 
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
This commit is contained in:
Ludovic Courtès 2024-10-22 15:01:48 +02:00
parent 9793403bc0
commit c62f8ab11f
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 72 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

74
guix/derivations.scm
View file

@ -401,8 +401,8 @@ (define* (derivation-build-plan store inputs
(substitution-oracle (substitution-oracle
store inputs #:mode mode))) store inputs #:mode mode)))
"Given INPUTS, a list of derivation-inputs, return two values: the list of "Given INPUTS, a list of derivation-inputs, return two values: the list of
derivations to build, and the list of substitutable items that, together, derivations to build, in topological order, and the list of substitutable
allow INPUTS to be realized. items that, together, allow INPUTS to be realized.
SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
by 'substitution-oracle'." by 'substitution-oracle'."
@ -422,36 +422,48 @@ (define (input-substitutable-info input)
(and (= (length info) (length items)) (and (= (length info) (length items))
info)))) info))))
(let loop ((inputs inputs) ;list of <derivation-input> (define (traverse)
(build '()) ;list of <derivation> ;; Perform a depth-first traversal.
(substitute '()) ;list of <substitutable> (let loop ((inputs inputs) ;list of <derivation-input>
(visited (set))) ;set of <derivation-input> (build '()) ;list of <derivation>
(match inputs (substitute '()) ;list of <substitutable>
(() (visited (set))) ;set of <derivation-input>
(values build substitute)) (match inputs
((input rest ...) (()
(let ((key (derivation-input-key input)) (values visited build substitute))
(deps (derivation-inputs ((input rest ...)
(derivation-input-derivation input)))) (let ((key (derivation-input-key input))
(cond ((set-contains? visited key) (deps (derivation-inputs
(loop rest build substitute visited)) (derivation-input-derivation input))))
((input-built? input) (cond ((set-contains? visited key)
(loop rest build substitute (loop rest build substitute visited))
(set-insert key visited))) ((input-built? input)
((input-substitutable-info input) (loop rest build substitute (set-insert key visited)))
=> ((input-substitutable-info input)
(lambda (substitutables) =>
(loop (append (dependencies-of-substitutables substitutables (lambda (substitutables)
(call-with-values
(lambda ()
(loop (dependencies-of-substitutables substitutables
deps) deps)
rest) build
build (append substitutables substitute)
(append substitutables substitute) (set-insert key visited)))
(set-insert key visited)))) (lambda (visited build substitute)
(else (loop rest build substitute visited)))))
(loop (append deps rest) (else
(cons (derivation-input-derivation input) build) (call-with-values
substitute (lambda ()
(set-insert key visited))))))))) (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) (define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
derivation-build-plan derivation-build-plan

31
tests/derivations.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -29,7 +29,8 @@ (define-module (test-derivations)
#:use-module (guix tests git) #:use-module (guix tests git)
#:use-module (guix tests http) #:use-module (guix tests http)
#:use-module ((guix packages) #:select (package-derivation base32)) #: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 ((guix hash) #:select (file-hash*))
#:use-module ((git oid) #:select (oid->string)) #:use-module ((git oid) #:select (oid->string))
#:use-module ((git reference) #:select (reference-name->oid)) #:use-module ((git reference) #:select (reference-name->oid))
@ -1157,6 +1158,32 @@ (define %coreutils
#:mode (build-mode check)) #:mode (build-mode check))
(list drv dep)))))) (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" (test-assert "derivation-input-fold"
(let* ((builder (add-text-to-store %store "my-builder.sh" (let* ((builder (add-text-to-store %store "my-builder.sh"
"echo hello, world > \"$out\"\n" "echo hello, world > \"$out\"\n"