From 2f170893719e6e9fc8e19cc5f0568e20a95d92b4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 13 May 2022 16:47:49 +0200
Subject: store: Use a decaying cutoff in 'map/accumulate-builds'.

This reduces the wall-clock time of:

  ./pre-inst-env guix system vm gnu/system/examples/desktop.tmpl -n

from 2m13s to 53s (the timings depend on which derivations have already
been built and are in store; in this case, many were missing).

* guix/store.scm (default-cutoff): New variable.
(map/accumulate-builds): Use it.  Parameterize it in recursive calls to
have decaying cutoff.
---
 guix/store.scm | 39 +++++++++++++++++++++++----------------
 1 file changed, 23 insertions(+), 16 deletions(-)

(limited to 'guix/store.scm')

diff --git a/guix/store.scm b/guix/store.scm
index 220901f6ce..a3240eb2e0 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1362,8 +1362,12 @@ object, only for build requests on EXPECTED-STORE."
         (unresolved things continue)
         (continue #t))))
 
+(define default-cutoff
+  ;; Default cutoff parameter for 'map/accumulate-builds'.
+  (make-parameter 32))
+
 (define* (map/accumulate-builds store proc lst
-                                #:key (cutoff 30))
+                                #:key (cutoff (default-cutoff)))
   "Apply PROC over each element of LST, accumulating 'build-things' calls and
 coalescing them into a single call.
 
@@ -1377,21 +1381,24 @@ CUTOFF is the threshold above which we stop accumulating unresolved nodes."
     (build-accumulator store))
 
   (define-values (result rest)
-    (let loop ((lst lst)
-               (result '())
-               (unresolved 0))
-      (match lst
-        ((head . tail)
-         (match (with-build-handler accumulator
-                  (proc head))
-           ((? unresolved? obj)
-            (if (>= unresolved 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)))))
+    ;; Have the default cutoff decay as we go deeper in the call stack to
+    ;; avoid pessimal behavior.
+    (parameterize ((default-cutoff (quotient cutoff 2)))
+      (let loop ((lst lst)
+                 (result '())
+                 (unresolved 0))
+        (match lst
+          ((head . tail)
+           (match (with-build-handler accumulator
+                    (proc head))
+             ((? unresolved? obj)
+              (if (>= unresolved 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)
-- 
cgit v1.2.3