#73948 [PATCH 0/2] 'derivation-build-plan' returns builds in topological order

Message #8 received at 73948@debbugs.gnu.org (full text, mbox, reply):

Received: (at 73948) by debbugs.gnu.org; 22 Oct 2024 13:25:09 +0000
From debbugs-submit-bounces@debbugs.gnu.org Tue Oct 22 09:25:09 2024
Received: from localhost ([127.0.0.1]:55054 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces@debbugs.gnu.org>)
	id 1t3Esm-0002ka-Gh
	for submit@debbugs.gnu.org; Tue, 22 Oct 2024 09:25:09 -0400
Received: from eggs.gnu.org ([209.51.188.92]:49048)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <ludo@gnu.org>) id 1t3Esk-0002hu-Qh
 for 73948@debbugs.gnu.org; Tue, 22 Oct 2024 09:25:07 -0400
Received: from fencepost.gnu.org ([2001:470:142:3::e])
 by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <ludo@gnu.org>)
 id 1t3Eq6-0006wW-BO; Tue, 22 Oct 2024 09:22:22 -0400
DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org;
 s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To:
 From; bh=qRpQMrJMJvuB1Ddne9oUw/ktsevOErvLmwhuqfaWleM=; b=ERI0yGBUzd3uB5XSSJnv
 hb8E0a3NbCcUAZaUWR3erZkn8R2AV/s8xMq5aXDDKdqnzo0NJgJXIwHZVrqnWoDAIX2mPCY4anagA
 IbtGjZABu8r6Q8t4473PQ8g2zxwE5+evwdrPl+8hUf5GSeErCXiJefN7/QmtqS2VkzLn+mxMUWlBf
 FdilMLiXYL+I7lHlab4Qmk/K48r5qbUrqsgkusnmjKpG/5a5iYu4GgxnqYeUx3rjTdC/CD2SF3ZY7
 KpZK7Jnz1pSJhJyKSnFYEQ63fHUGGi9lDLIETVFqhtFe1Xc+wrEO8PAvnJr72LcTHE/8OTKJz0bQ/
 GbR7SW/9GkjRrw==;
From: Ludovic Courtès <ludo@gnu.org>
To: 73948@debbugs.gnu.org
Subject: [PATCH 1/2] derivations: ‘derivation-build-plan’ returns builds in topological order.
Date: Tue, 22 Oct 2024 15:22:09 +0200
Message-ID: <d105af40ba2e22b10f68786d0d440fb9bc1113d7.1729603127.git.ludo@gnu.org>
X-Mailer: git-send-email 2.46.0
In-Reply-To: <cover.1729603127.git.ludo@gnu.org>
References: <cover.1729603127.git.ludo@gnu.org>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
X-Debbugs-Cc: Christopher Baines <guix@cbaines.net>, Josselin Poiret <dev@jpoiret.xyz>, Ludovic Courtès <ludo@gnu.org>, Mathieu Othacehe <othacehe@gnu.org>, Simon Tournier <zimon.toutoune@gmail.com>, Tobias Geerinckx-Rice <me@tobias.gr>
Content-Transfer-Encoding: 8bit
X-Spam-Score: -2.3 (--)
X-Debbugs-Envelope-To: 73948
Cc: Ludovic Courtès <ludo@gnu.org>
X-BeenThere: debbugs-submit@debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request@debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit@debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request@debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request@debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces@debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces@debbugs.gnu.org>
X-Spam-Score: -3.3 (---)

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(-)

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

Send a report that this bug log contains spam.