diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index 3a68a12..f8c44b2 100644 --- a/knots/thread-pool.scm +++ b/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 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 - (lambda (i) - (if use-default-io-waiters? - (call-with-default-io-waiters - (lambda () - (start-thread i channel))) - (start-thread i channel))) - (iota size)) + (define threads + (map (lambda (i) + (if use-default-io-waiters? + (call-with-default-io-waiters + (lambda () + (start-thread i channel))) + (start-thread i channel))) + (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 - (fixed-size-thread-pool-channel pool) - 'destroy) + (let ((channel (fixed-size-thread-pool-channel pool)) + (threads (fixed-size-thread-pool-threads pool))) + (for-each (lambda _ (put-message channel 'destroy)) threads) + (for-each join-thread threads)) (destroy-resource-pool (thread-pool-resource-pool pool)))) diff --git a/tests/thread-pool.scm b/tests/thread-pool.scm index e3a1cdd..dc22119 100644 --- a/tests/thread-pool.scm +++ b/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")