From c2f0c5b36f8294bb4c699806f9e8c576ae9b9f90 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 20 Jun 2021 20:39:44 +0100
Subject: Support thread-stop-delay for the work queues

This is useful when builds finish quickly since there could be more than 2
idle threads, and then threads start stopping. This way, each thread waits 20
seconds before stopping, which should be enough time for new builds to be
fetched.
---
 guix-build-coordinator/agent.scm |  7 ++++++-
 guix-build-coordinator/utils.scm | 33 ++++++++++++++++++++++-----------
 2 files changed, 28 insertions(+), 12 deletions(-)

diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index 7966020..a89e5d7 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -321,7 +321,12 @@
                                      (max 5
                                           (- 135
                                              (* 120
-                                                (/ max-parallel-builds 64))))))))
+                                                (/ max-parallel-builds 64)))))
+                                    #:thread-stop-delay
+                                    (make-time
+                                     time-duration
+                                     0
+                                     20))))
     (define (display-info)
       (display
        (simple-format
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 7504559..c619a12 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -677,7 +677,9 @@ References: ~a~%"
   (call-with-time-logging name (lambda () exp ...)))
 
 (define* (create-work-queue thread-count-parameter proc
-                            #:key thread-start-delay)
+                            #:key thread-start-delay
+                            (thread-stop-delay
+                             (make-time time-duration 0 0)))
   (let ((queue (make-q))
         (queue-mutex (make-mutex))
         (job-available (make-condition-variable))
@@ -748,13 +750,16 @@ References: ~a~%"
                (hash-count (lambda (index val)
                              (list? val))
                            running-job-args))
-              (idle-thread-count
-               (hash-count (lambda (index val)
-                             (eq? #f val))
-                           running-job-args))
               (desired-thread-count (get-thread-count)))
-          (or (>= running-jobs-count desired-thread-count)
-              (> idle-thread-count 2))))
+
+          (>= running-jobs-count
+              desired-thread-count)))
+
+      (define (thread-idle-for-too-long? last-job-finished-at)
+        (time>=?
+         (time-difference (current-time time-monotonic)
+                          last-job-finished-at)
+         thread-stop-delay))
 
       (define (stop-thread)
         (hash-remove! running-job-args
@@ -763,7 +768,7 @@ References: ~a~%"
 
       (call-with-new-thread
        (lambda ()
-         (let loop ()
+         (let loop ((last-job-finished-at (current-time time-monotonic)))
            (lock-mutex queue-mutex)
 
            (if (too-many-threads?)
@@ -795,10 +800,16 @@ References: ~a~%"
                        (with-mutex queue-mutex
                          (hash-set! running-job-args
                                     thread-index
-                                    #f)))
-                     (unlock-mutex queue-mutex))
+                                    #f))
+
+                       (loop (current-time time-monotonic)))
+                     (if (thread-idle-for-too-long? last-job-finished-at)
+                         (stop-thread)
+                         (begin
+                           (unlock-mutex queue-mutex)
+
+                           (loop last-job-finished-at))))))))))
 
-                 (loop)))))))
 
     (define start-new-threads-if-necessary
       (let ((previous-thread-started-at (make-time time-monotonic 0 0)))
-- 
cgit v1.2.3