From 232b3d31016439b5600e47d845ffb7c9a4ee4723 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 17 Nov 2017 10:10:30 +0100
Subject: workers: 'pool-idle?' returns true only if the workers are idle.

Fixes <https://bugs.gnu.org/28779>.
Reported by Eric Bavier <bavier@cray.com>.

* guix/workers.scm (<pool>)[busy]: New field.
(worker-thunk): Add #:idle and #:busy and use them.
(make-pool): Pass #:busy and #:idle to 'worker-thunk'.  Pass a 'busy'
value to '%make-pool'.
* guix/workers.scm (pool-idle?): Check whether 'pool-busy' returns zero
and adjust docstring.
---
 guix/workers.scm | 24 +++++++++++++++++-------
 1 file changed, 17 insertions(+), 7 deletions(-)

diff --git a/guix/workers.scm b/guix/workers.scm
index 846f5e50a9..0f6f54bab0 100644
--- a/guix/workers.scm
+++ b/guix/workers.scm
@@ -45,12 +45,13 @@
 ;;; Code:
 
 (define-record-type <pool>
-  (%make-pool queue mutex condvar workers)
+  (%make-pool queue mutex condvar workers busy)
   pool?
   (queue    pool-queue)
   (mutex    pool-mutex)
   (condvar  pool-condition-variable)
-  (workers  pool-workers))
+  (workers  pool-workers)
+  (busy     pool-busy))
 
 (define-syntax-rule (without-mutex mutex exp ...)
   (dynamic-wind
@@ -62,12 +63,14 @@
       (lock-mutex mutex))))
 
 (define* (worker-thunk mutex condvar pop-queue
-                       #:key (thread-name "guix worker"))
+                       #:key idle busy (thread-name "guix worker"))
   "Return the thunk executed by worker threads."
   (define (loop)
     (match (pop-queue)
       (#f                                         ;empty queue
-       (wait-condition-variable condvar mutex))
+       (idle)
+       (wait-condition-variable condvar mutex)
+       (busy))
       ((? procedure? proc)
        ;; Release MUTEX while executing PROC.
        (without-mutex mutex
@@ -97,19 +100,24 @@ threads as reported by the operating system."
   (let* ((mutex   (make-mutex))
          (condvar (make-condition-variable))
          (queue   (make-q))
+         (busy    count)
          (procs   (unfold (cut >= <> count)
                           (lambda (n)
                             (worker-thunk mutex condvar
                                           (lambda ()
                                             (and (not (q-empty? queue))
                                                  (q-pop! queue)))
+                                          #:busy (lambda ()
+                                                   (set! busy (+ 1 busy)))
+                                          #:idle (lambda ()
+                                                   (set! busy (- busy 1)))
                                           #:thread-name thread-name))
                           1+
                           0))
          (threads (map (lambda (proc)
                          (call-with-new-thread proc))
                        procs)))
-    (%make-pool queue mutex condvar threads)))
+    (%make-pool queue mutex condvar threads (lambda () busy))))
 
 (define (pool-enqueue! pool thunk)
   "Enqueue THUNK for future execution by POOL."
@@ -118,9 +126,11 @@ threads as reported by the operating system."
     (signal-condition-variable (pool-condition-variable pool))))
 
 (define (pool-idle? pool)
-  "Return true if POOL doesn't have any task in its queue."
+  "Return true if POOL doesn't have any task in its queue and all the workers
+are currently idle (i.e., waiting for a task)."
   (with-mutex (pool-mutex pool)
-    (q-empty? (pool-queue pool))))
+    (and (q-empty? (pool-queue pool))
+         (zero? ((pool-busy pool))))))
 
 (define-syntax-rule (eventually pool exp ...)
   "Run EXP eventually on one of the workers of POOL."
-- 
cgit 1.4.1