01/08: store: Add 'map/accumulate-builds' cutoff to address pathological cases.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit fa81971cbae85b39183ccf8f51e8d96ac88fb4ac
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Aug 10 12:24:44 2021 +0200

    store: Add 'map/accumulate-builds' cutoff to address pathological cases.
    
    Fixes <https://bugs.gnu.org/49439>.
    Reported by Ricardo Wurmus <rekado@elephly.net>.
    
    Previously, a command such as:
    
      guix environment pigx-scrnaseq
    
    could lead to unbounded memory growth and could even fail to complete
    when some items are missing from the store.  This was because
    'map/accumulate-builds' callees would keep making .drv build requests
    that were turned into <unresolved> nodes; in this case, there are often
    many identical build requests.  Stopping accumulation earlier allows us
    to unlock the situation by proceeding with the first few build requests
    instead of spinning until we've accumulated all the build requests.
    
    * guix/store.scm (map/accumulate-builds): Define 'accumulation-cutoff'.
    Use a loop when iterating over LST and maintain a counter of unresolved
    nodes met so far; return when the counter exceeds ACCUMULATION-CUTOFF.
---
 guix/store.scm | 30 ++++++++++++++++++++++++------
 1 file changed, 24 insertions(+), 6 deletions(-)

diff --git a/guix/store.scm b/guix/store.scm
index 1ab2b08..0463b0e 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1358,11 +1358,28 @@ on the build output of a previous derivation."
 (define (map/accumulate-builds store proc lst)
   "Apply PROC over each element of LST, accumulating 'build-things' calls and
 coalescing them into a single call."
-  (define result
-    (map (lambda (obj)
-           (with-build-handler build-accumulator
-             (proc obj)))
-         lst))
+  (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)
+
+  (define-values (result rest)
+    (let loop ((lst lst)
+               (result '())
+               (unresolved 0))
+      (match lst
+        ((head . tail)
+         (match (with-build-handler build-accumulator
+                  (proc head))
+           ((? unresolved? obj)
+            (if (> unresolved accumulation-cutoff)
+                (values (reverse (cons obj result)) tail)
+                (loop tail (cons obj result) (+ 1 unresolved))))
+           (obj
+            (loop tail (cons obj result) unresolved))))
+        (()
+         (values (reverse result) lst)))))
 
   (match (append-map (lambda (obj)
                        (if (unresolved? obj)
@@ -1370,6 +1387,7 @@ coalescing them into a single call."
                            '()))
                      result)
     (()
+     ;; REST is necessarily empty.
      result)
     (to-build
      ;; We've accumulated things TO-BUILD.  Actually build them and resume the
@@ -1382,7 +1400,7 @@ coalescing them into a single call."
                                   ;; unnecessary.
                                   ((unresolved-continuation obj) #f)
                                   obj))
-                            result))))
+                            (append result rest)))))
 
 (define build-things
   (let ((build (operation (build-things (string-list things)