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
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 (input-substitutable-info input)
(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

31
tests/derivations.scm
View file

@ -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"