diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index df4352a..cbbaf21 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -270,7 +270,7 @@ from there, or #f if that would be an empty string." (destructor/safe args))))) (define (process thread-index channel args) - (let loop () + (let loop ((lifetime thread-lifetime)) (match (get-message channel) ('destroy #f) ((reply sent-time proc) @@ -342,7 +342,11 @@ from there, or #f if that would be an empty string." (if (and exception? expire-on-exception?) #t - (loop)))))))) + (if lifetime + (if (<= 1 lifetime) + #t + (loop (- lifetime 1))) + (loop lifetime))))))))) (define (start-thread index channel) (call-with-new-thread @@ -416,7 +420,6 @@ arguments of the thread pool procedure." 1 #:thread-initializer thread-initializer #:thread-destructor thread-destructor - #:thread-lifetime thread-lifetime #:expire-on-exception? expire-on-exception? #:name name #:use-default-io-waiters? use-default-io-waiters?)) @@ -424,6 +427,7 @@ arguments of the thread pool procedure." #:destructor destroy-thread-pool #:min-size min-size #:delay-logger delay-logger + #:lifetime thread-lifetime #:scheduler scheduler #:duration-logger duration-logger #:default-checkout-timeout default-checkout-timeout diff --git a/tests/thread-pool.scm b/tests/thread-pool.scm index 1c51cb3..dd0b852 100644 --- a/tests/thread-pool.scm +++ b/tests/thread-pool.scm @@ -85,4 +85,26 @@ (+ 1 'a)))) #:unwind? #t))))) +(let ((thread-pool + (make-fixed-size-thread-pool 1 #:thread-lifetime 1))) + + (for-each + (lambda _ + (call-with-thread + thread-pool + (lambda () #f))) + (iota 10))) + +(run-fibers-for-tests + (lambda () + (let ((thread-pool + (make-thread-pool 1 #:thread-lifetime 1))) + + (for-each + (lambda _ + (call-with-thread + thread-pool + (lambda () #f))) + (iota 10))))) + (display "thread-pool test finished successfully\n")