From f549bee282e108bc5f68ba885a0b2ba53b82e373 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Wed, 26 Feb 2025 10:07:54 +0000
Subject: [PATCH] Improve thread pool exception logging

---
 knots/thread-pool.scm | 21 ++++++++++-----------
 1 file changed, 10 insertions(+), 11 deletions(-)

diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm
index 69010c6..7c25498 100644
--- a/knots/thread-pool.scm
+++ b/knots/thread-pool.scm
@@ -251,7 +251,15 @@ arguments of the thread pool procedure."
                               (vector-set! thread-proc-vector
                                            thread-index
                                            proc)
-                              (with-throw-handler #t
+                              (with-exception-handler
+                                  (lambda (exn)
+                                    (when (log-exception? exn)
+                                      (simple-format
+                                       (current-error-port)
+                                       "thread-pool: exception running ~A\n" proc)
+                                      (print-backtrace-and-exception/knots
+                                       exn))
+                                    (raise-exception exn))
                                 (lambda ()
                                   (call-with-values
                                       (lambda ()
@@ -262,16 +270,7 @@ arguments of the thread pool procedure."
                                       (cons (/ (- (get-internal-real-time)
                                                   start-time)
                                                internal-time-units-per-second)
-                                            vals))))
-                                (lambda args
-                                  (when (match args
-                                          (('%exception exn)
-                                           (log-exception? exn))
-                                          (_ #t))
-                                    (simple-format
-                                     (current-error-port)
-                                     "thread-pool: exception: ~A\n" args)
-                                    (backtrace)))))
+                                            vals))))))
                             #:unwind? #t)))
                     (put-message reply
                                  response)