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.

1 files changed, 22 insertions, 11 deletions

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