01/03: store: 'map/accumulate-builds' processes the whole list in case of cutoff.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit f72f4b48c6777da9465ab17baa6762476d6cb270
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Sep 15 16:23:48 2021 +0200

    store: 'map/accumulate-builds' processes the whole list in case of cutoff.
    
    Fixes <https://issues.guix.gnu.org/50264>.
    Reported by Lars-Dominik Braun <lars@6xq.net>.
    
    This fixes a regression introduced in
    fa81971cbae85b39183ccf8f51e8d96ac88fb4ac whereby 'map/accumulate-builds'
    would return REST (the tail of LST) without applying PROC on it.  The
    effect would be that 'lower-inputs' in (guix gexp) would dismiss those
    elements, leading to derivations with correct builders but only a subset
    of the inputs they should have had.
    
    * guix/store.scm (map/accumulate-builds): Add #:cutoff parameter and
    remove 'accumulation-cutoff' variable.  Call PROC on the elements of
    REST.
    * tests/store.scm ("map/accumulate-builds cutoff"): New test.
---
 guix/store.scm  | 41 +++++++++++++++++++++++------------------
 tests/store.scm | 36 ++++++++++++++++++++++++++++++++++++
 2 files changed, 59 insertions(+), 18 deletions(-)

diff --git a/guix/store.scm b/guix/store.scm
index 0463b0e..89a719b 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1355,14 +1355,16 @@ on the build output of a previous derivation."
       (unresolved things continue)
       (continue #t)))
 
-(define (map/accumulate-builds store proc lst)
+(define* (map/accumulate-builds store proc lst
+                                #:key (cutoff 30))
   "Apply PROC over each element of LST, accumulating 'build-things' calls and
-coalescing them into a single call."
-  (define accumulation-cutoff
-    ;; Threshold above which we stop accumulating unresolved nodes to avoid
-    ;; pessimal behavior where we keep stumbling upon the same .drv build
-    ;; requests with many incoming edges.  See <https://bugs.gnu.org/49439>.
-    30)
+coalescing them into a single call.
+
+CUTOFF is the threshold above which we stop accumulating unresolved nodes."
+
+  ;; The CUTOFF parameter helps avoid pessimal behavior where we keep
+  ;; stumbling upon the same .drv build requests with many incoming edges.
+  ;; See <https://bugs.gnu.org/49439>.
 
   (define-values (result rest)
     (let loop ((lst lst)
@@ -1373,7 +1375,7 @@ coalescing them into a single call."
          (match (with-build-handler build-accumulator
                   (proc head))
            ((? unresolved? obj)
-            (if (> unresolved accumulation-cutoff)
+            (if (>= unresolved cutoff)
                 (values (reverse (cons obj result)) tail)
                 (loop tail (cons obj result) (+ 1 unresolved))))
            (obj
@@ -1390,17 +1392,20 @@ coalescing them into a single call."
      ;; REST is necessarily empty.
      result)
     (to-build
-     ;; We've accumulated things TO-BUILD.  Actually build them and resume the
-     ;; corresponding continuations.
+     ;; We've accumulated things TO-BUILD; build them.
      (build-things store (delete-duplicates to-build))
-     (map/accumulate-builds store
-                            (lambda (obj)
-                              (if (unresolved? obj)
-                                  ;; Pass #f because 'build-things' is now
-                                  ;; unnecessary.
-                                  ((unresolved-continuation obj) #f)
-                                  obj))
-                            (append result rest)))))
+
+     ;; Resume the continuations corresponding to TO-BUILD, and then process
+     ;; REST.
+     (append (map/accumulate-builds store
+                                    (lambda (obj)
+                                      (if (unresolved? obj)
+                                          ;; Pass #f because 'build-things' is 
now
+                                          ;; unnecessary.
+                                          ((unresolved-continuation obj) #f)
+                                          obj))
+                                    result #:cutoff cutoff)
+         (map/accumulate-builds store proc rest #:cutoff cutoff)))))
 
 (define build-things
   (let ((build (operation (build-things (string-list things)
diff --git a/tests/store.scm b/tests/store.scm
index 3266fa7..95f47c3 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -454,6 +454,42 @@
                                              (derivation->output-path drv)))
                              (list d1 d2)))))
 
+(test-equal "map/accumulate-builds cutoff" ;https://issues.guix.gnu.org/50264
+  (iota 20)
+
+  ;; Make sure that, when the cutoff is reached, 'map/accumulate-builds' still
+  ;; returns the right result and calls the build handler by batches.
+  (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
+         (s  (add-to-store %store "bash" #t "sha256"
+                           (search-bootstrap-binary "bash"
+                                                    (%current-system))))
+         (d  (map (lambda (i)
+                    (derivation %store (string-append "the-thing-"
+                                                      (number->string i))
+                                s `("-e" ,b)
+                                #:env-vars `(("foo" . ,(random-text)))
+                                #:sources (list b s)
+                                #:properties `((n . ,i))))
+                  (iota 20)))
+         (calls '()))
+    (define lst
+      (with-build-handler (lambda (continue store things mode)
+                            (set! calls (cons things calls))
+                            (continue #f))
+        (map/accumulate-builds %store
+                               (lambda (d)
+                                 (build-derivations %store (list d))
+                                 (assq-ref (derivation-properties d) 'n))
+                               d
+                               #:cutoff 7)))
+
+    (match (reverse calls)
+      (((batch1 ...) (batch2 ...) (batch3 ...))
+       (and (equal? (map derivation-file-name (take d 8)) batch1)
+            (equal? (map derivation-file-name (take (drop d 8) 8)) batch2)
+            (equal? (map derivation-file-name (drop d 16)) batch3)
+            lst)))))
+
 (test-assert "mapm/accumulate-builds"
   (let* ((d1 (run-with-store %store
                (gexp->derivation "foo" #~(mkdir #$output))))