From 05ad83c7031de9b0d1873a0d5aec630746342a06 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 17 Nov 2025 11:37:26 +0000
Subject: [PATCH] Implement lifetime support for thread pools

---
 knots/thread-pool.scm | 10 +++++++---
 tests/thread-pool.scm | 22 ++++++++++++++++++++++
 2 files changed, 29 insertions(+), 3 deletions(-)

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