Fix the destroy behaviour for fixed size thread pools

destroy-thread-pool should block until the thread pool has been
destroyed.

knots/thread-pool.scm

@@ -163,12 +163,13 @@ from there, or #f if that would be an empty string."
 
 (define-record-type <fixed-size-thread-pool>
   (fixed-size-thread-pool channel arguments-parameter current-procedures
-                          default-checkout-timeout)
+                          default-checkout-timeout threads)
   fixed-size-thread-pool?
   (channel             fixed-size-thread-pool-channel)
   (arguments-parameter fixed-size-thread-pool-arguments-parameter)
   (current-procedures  fixed-size-thread-pool-current-procedures)
-  (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout))
+  (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout)
+  (threads             fixed-size-thread-pool-threads))
 
 ;; Since both thread pool records have this field, use a procedure
 ;; than handles the appropriate accessor
@@ -426,19 +427,20 @@ completes.
                        (initializer/safe)
                        '()))))))))
 
-  (for-each
+  (define threads
-   (lambda (i)
+    (map (lambda (i)
-     (if use-default-io-waiters?
+           (if use-default-io-waiters?
-         (call-with-default-io-waiters
+               (call-with-default-io-waiters
-          (lambda ()
+                (lambda ()
-            (start-thread i channel)))
+                  (start-thread i channel)))
-         (start-thread i channel)))
+               (start-thread i channel)))
-   (iota size))
+         (iota size)))
 
   (fixed-size-thread-pool channel
                           param
                           thread-proc-vector
-                          default-checkout-timeout))
+                          default-checkout-timeout
+                          threads))
 
 (define* (make-thread-pool max-size
                            #:key
@@ -627,9 +629,13 @@ Override the channel used to communicate with the thread.
                     destroy-thread-on-exception?))))))))
 
 (define (destroy-thread-pool pool)
+  "Destroy POOL, stopping all of its threads and calling the destructor
+if specified.  This procedure will block until the destruction is
+complete."
   (if (fixed-size-thread-pool? pool)
-      (put-message
+      (let ((channel (fixed-size-thread-pool-channel pool))
-       (fixed-size-thread-pool-channel pool)
+            (threads (fixed-size-thread-pool-threads pool)))
-       'destroy)
+        (for-each (lambda _ (put-message channel 'destroy)) threads)
+        (for-each join-thread threads))
       (destroy-resource-pool
        (thread-pool-resource-pool pool))))

tests/thread-pool.scm

@@ -1,5 +1,6 @@
 (use-modules (tests)
              (ice-9 atomic)
+             (ice-9 threads)
              (srfi srfi-71)
              (fibers)
              (unit-test)
@@ -142,4 +143,33 @@
                 ref-and-decrement))
     (error)))
 
+;; Test that the destructor is called when a size 1 fixed-size thread
+;; pool is destroyed, and that destroy-thread-pool blocks until it has
+;; completed.
+(let* ((destructor-called? #f)
+       (thread-pool
+        (make-fixed-size-thread-pool
+         1
+         #:thread-destructor
+         (lambda ()
+           (set! destructor-called? #t)))))
+  (destroy-thread-pool thread-pool)
+  (assert-equal #t destructor-called?))
+
+;; Test that the destructor is called for every thread when a
+;; multi-thread fixed-size thread pool is destroyed, and that
+;; destroy-thread-pool blocks until all destructors have completed.
+(let* ((destructor-count 0)
+       (mutex (make-mutex))
+       (pool-size 3)
+       (thread-pool
+        (make-fixed-size-thread-pool
+         pool-size
+         #:thread-destructor
+         (lambda ()
+           (with-mutex mutex
+             (set! destructor-count (+ destructor-count 1)))))))
+  (destroy-thread-pool thread-pool)
+  (assert-equal pool-size destructor-count))
+
 (display "thread-pool test finished successfully\n")