From da69fd19f3072a405e394881a11c345704f31806 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Tue, 11 Mar 2025 11:55:42 +0000
Subject: [PATCH] Unwind before calling put-message

As I think this might be more reliable in case the stack contains
something that would introduce a continuation barrier.
---
 knots/parallelism.scm | 87 +++++++++++++++++++++++--------------------
 1 file changed, 47 insertions(+), 40 deletions(-)

diff --git a/knots/parallelism.scm b/knots/parallelism.scm
index 77272dd..ab398f8 100644
--- a/knots/parallelism.scm
+++ b/knots/parallelism.scm
@@ -22,6 +22,7 @@
   #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:use-module (ice-9 control)
+  #:use-module (ice-9 exceptions)
   #:use-module (fibers)
   #:use-module (fibers channels)
   #:use-module (fibers operations)
@@ -43,27 +44,30 @@
   (let ((reply (make-channel)))
     (spawn-fiber
      (lambda ()
-       (call-with-escape-continuation
-        (lambda (return)
-          (with-exception-handler
-              (lambda (exn)
-                (match (fluid-ref %stacks)
-                  ((stack-tag . prompt-tag)
-                   (let ((stack (make-stack #t
-                                            0 prompt-tag
-                                            0 (and prompt-tag 1))))
-                     (put-message reply
-                                  (list 'exception
-                                        (make-exception
-                                         exn
-                                         (make-knots-exception stack)))))))
-                (return))
-            (lambda ()
-              (call-with-values
-                  (lambda ()
-                    (start-stack #t (thunk)))
-                (lambda vals
-                  (put-message reply vals))))))))
+       (with-exception-handler
+           (lambda (exn)
+             (put-message
+              reply
+              (list 'exception exn)))
+         (lambda ()
+           (with-exception-handler
+               (lambda (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 #t (thunk)))
+                 (lambda vals
+                   (put-message reply vals))))))
+         #:unwind? #t))
      #:parallel? #t)
     reply))
 
@@ -245,25 +249,28 @@
                                      (get-message process-channel))))
             (put-message
              reply-channel
-             (call-with-escape-continuation
-              (lambda (return)
-                (with-exception-handler
-                    (lambda (exn)
-                      (match (fluid-ref %stacks)
-                        ((stack-tag . prompt-tag)
-                         (let ((stack (make-stack #t
-                                                  0 prompt-tag
-                                                  0 (and prompt-tag 1))))
-                           (return (list 'exception
-                                         (make-exception
-                                          exn
-                                          (make-knots-exception stack))))))))
-                  (lambda ()
-                    (call-with-values
-                        (lambda ()
-                          (start-stack #t (apply proc args)))
-                      (lambda vals
-                        (cons 'result vals)))))))))))
+             (with-exception-handler
+                 (lambda (exn)
+                   (list 'exception exn))
+               (lambda ()
+                 (with-exception-handler
+                     (lambda (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 #t (apply proc args)))
+                       (lambda vals
+                         (cons 'result vals))))))
+               #:unwind? #t)))))
       #:parallel? #t))
    (iota parallelism))