From ed4113af513ea5f130e5e46d99b5d82bbd85c492 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Thu, 27 Feb 2025 12:08:41 +0000
Subject: [PATCH] Simplify and extend using the knots exception with stack

---
 knots/parallelism.scm | 31 ++++++++++---------------------
 knots/thread-pool.scm | 18 ++++++++++--------
 tests/thread-pool.scm | 18 ++++++++++++++++++
 3 files changed, 38 insertions(+), 29 deletions(-)

diff --git a/knots/parallelism.scm b/knots/parallelism.scm
index 1210c19..f9be4ff 100644
--- a/knots/parallelism.scm
+++ b/knots/parallelism.scm
@@ -52,7 +52,11 @@
                    (let ((stack (make-stack #t
                                             0 prompt-tag
                                             0 (and prompt-tag 1))))
-                     (put-message reply (list 'exception exn stack)))))
+                     (put-message reply
+                                  (list 'exception
+                                        (make-exception
+                                         exn
+                                         (make-knots-exception stack)))))))
                 (return))
             (lambda ()
               (call-with-values
@@ -69,12 +73,7 @@
     (map
      (match-lambda
        (('exception exn stack)
-        (let ((knots-exn
-               (make-knots-exception stack)))
-          (raise-exception
-           (make-exception
-            knots-exn
-            exn))))
+        (raise-exception exn))
        (result
         (apply values result)))
      responses)))
@@ -118,13 +117,8 @@
                           (vector-ref result-vec index))
                          (lambda (result)
                            (match result
-                             (('exception exn stack)
-                              (let ((knots-exn
-                                     (make-knots-exception stack)))
-                                (raise-exception
-                                 (make-exception
-                                  knots-exn
-                                  exn))))
+                             (('exception exn)
+                              (raise-exception exn))
                              (_
                               (vector-set! result-vec
                                            index
@@ -275,10 +269,5 @@
       (put-message input-channel (cons reply-channel args))
       (match (get-message reply-channel)
         (('result . vals) (apply values vals))
-        (('exception exn stack)
-         (let ((knots-exn
-                (make-knots-exception stack)))
-           (raise-exception
-            (make-exception
-             knots-exn
-             exn))))))))
+        (('exception exn)
+         (raise-exception exn))))))
diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm
index 7c25498..3b87be1 100644
--- a/knots/thread-pool.scm
+++ b/knots/thread-pool.scm
@@ -253,18 +253,20 @@ arguments of the thread pool procedure."
                                            proc)
                               (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))
+                                    (match (fluid-ref %stacks)
+                                      ((stack-tag . prompt-tag)
+                                       (let ((stack (make-stack #t
+                                                                0 prompt-tag
+                                                                0 (and prompt-tag 1))))
+                                         (raise-exception
+                                          (make-exception
+                                           exn
+                                           (make-knots-exception stack)))))))
                                 (lambda ()
                                   (call-with-values
                                       (lambda ()
                                         (start-stack
-                                         'thread-pool
+                                         #t
                                          (apply proc args)))
                                     (lambda vals
                                       (cons (/ (- (get-internal-real-time)
diff --git a/tests/thread-pool.scm b/tests/thread-pool.scm
index 71b4494..93a49ce 100644
--- a/tests/thread-pool.scm
+++ b/tests/thread-pool.scm
@@ -2,6 +2,7 @@
              (srfi srfi-71)
              (fibers)
              (unit-test)
+             (knots)
              (knots thread-pool))
 
 (let ((thread-pool
@@ -41,4 +42,21 @@
 
   (process-job 3))
 
+(let ((thread-pool
+       (make-thread-pool 2)))
+
+  (run-fibers-for-tests
+   (lambda ()
+     (assert-equal
+      #t
+      (with-exception-handler
+          (lambda (exn)
+            (knots-exception? exn))
+        (lambda ()
+          (call-with-thread
+           thread-pool
+           (lambda ()
+             (+ 1 'a))))
+        #:unwind? #t)))))
+
 (display "thread-pool test finished successfully\n")