[Guile-commits] 18/18: Fix exn dispatch for exns within pre-unwind handlers

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 02dfb6e7767c4946daa2aef1985007128f35351f
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Wed Jun 7 22:26:05 2023 +0200

    Fix exn dispatch for exns within pre-unwind handlers
    
    * libguile/exceptions.c (exception_epoch_fluid): Rename from
    active_exception_handlers_fluid.
    (scm_dynwind_throw_handler): Increment exception epoch instead of
    resetting active exception handlers.
    (scm_init_exceptions): Update.
    * module/ice-9/boot-9.scm  (with-exception-handler): Rework to associate
    an "epoch" fluid with each exception handler.
    (with-throw-handler): Establish a new epoch, during the execution of a
    throw handler.
    (raise-exception): Rework to avoid capturing a list of exception
    handlers, and to use epochs as a way to know which handlers have already
    been examined and which are on the dispatch stack.
    * test-suite/tests/exceptions.test ("throwing within exception
    handlers"): New test.
---
 libguile/exceptions.c            |  11 +++--
 module/ice-9/boot-9.scm          | 104 ++++++++++++++++++++++++---------------
 test-suite/tests/exceptions.test |  12 +++++
 3 files changed, 81 insertions(+), 46 deletions(-)

diff --git a/libguile/exceptions.c b/libguile/exceptions.c
index 1fe281bc5..8b462955f 100644
--- a/libguile/exceptions.c
+++ b/libguile/exceptions.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-1998,2000-2001,2003-2004,2006,2008,2009-2014,2017-2019
+/* Copyright 1995-1998,2000-2001,2003-2004,2006,2008,2009-2014,2017-2019,2023
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -109,7 +109,7 @@ call_exception_handler (SCM clo, SCM exn)
 SCM_KEYWORD (kw_unwind_p, "unwind?");
 SCM_KEYWORD (kw_unwind_for_type, "unwind-for-type");
 static SCM exception_handler_fluid;
-static SCM active_exception_handlers_fluid;
+static SCM exception_epoch_fluid;
 static SCM with_exception_handler_var;
 static SCM raise_exception_var;
 
@@ -257,7 +257,8 @@ exception_has_type (SCM exn, SCM type)
 void
 scm_dynwind_throw_handler (void)
 {
-  scm_dynwind_fluid (active_exception_handlers_fluid, SCM_BOOL_F);
+  SCM depth = scm_oneplus (scm_fluid_ref (exception_epoch_fluid));
+  scm_dynwind_fluid (exception_epoch_fluid, depth);
 }
 
 
@@ -499,11 +500,11 @@ scm_init_exceptions ()
   scm_set_smob_apply (tc16_exception_handler, call_exception_handler, 1, 0, 0);
 
   exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
-  active_exception_handlers_fluid = scm_make_thread_local_fluid (SCM_BOOL_F);
+  exception_epoch_fluid = scm_make_fluid_with_default (SCM_INUM1);
   /* These binding are later removed when the Scheme definitions of
      raise and with-exception-handler are created in boot-9.scm.  */
   scm_c_define ("%exception-handler", exception_handler_fluid);
-  scm_c_define ("%active-exception-handlers", active_exception_handlers_fluid);
+  scm_c_define ("%exception-epoch", exception_epoch_fluid);
 
   with_exception_handler_var =
     scm_c_define ("with-exception-handler", SCM_BOOL_F);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 686a9c87d..8aef6db75 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1586,8 +1586,7 @@ exception that is an instance of @var{rtd}."
         val))
 
     (define %exception-handler (steal-binding! '%exception-handler))
-    (define %active-exception-handlers
-      (steal-binding! '%active-exception-handlers))
+    (define %exception-epoch (steal-binding! '%exception-epoch))
     (define %init-exceptions! (steal-binding! '%init-exceptions!))
 
     (%init-exceptions! &compound-exception
@@ -1639,13 +1638,6 @@ If @var{continuable?} is true, the handler is invoked in 
tail position
 relative to the @code{raise-exception} call.  Otherwise if the handler
 returns, a non-continuable exception of type @code{&non-continuable} is
 raised in the same dynamic environment as the handler."
-      (define (capture-current-exception-handlers)
-        ;; FIXME: This is quadratic.
-        (let lp ((depth 0))
-          (let ((h (fluid-ref* %exception-handler depth)))
-            (if h
-                (cons h (lp (1+ depth)))
-                (list fallback-exception-handler)))))
       (define (exception-has-type? exn type)
         (cond
          ((eq? type #t)
@@ -1656,35 +1648,45 @@ raised in the same dynamic environment as the handler."
           (and (exception? exn)
                ((exception-predicate type) exn)))
          (else #f)))
-      (let lp ((handlers (or (fluid-ref %active-exception-handlers)
-                             (capture-current-exception-handlers))))
-        (let ((handler (car handlers))
-              (handlers (cdr handlers)))
-          ;; There are two types of exception handlers: unwinding handlers
-          ;; and pre-unwind handlers.  Although you can implement unwinding
-          ;; handlers with pre-unwind handlers, it's better to separate them
-          ;; because it allows for emergency situations like "stack
-          ;; overflow" or "out of memory" to unwind the stack before calling
-          ;; a handler.
-          (cond
-           ((pair? handler)
-            (let ((prompt-tag (car handler))
-                  (type (cdr handler)))
-              (cond
-               ((exception-has-type? exn type)
-                (abort-to-prompt prompt-tag exn)
-                (error "unreachable"))
-               (else
-                (lp handlers)))))
-           (else
-            (with-fluids ((%active-exception-handlers handlers))
-              (cond
-               (continuable?
-                (handler exn))
-               (else
-                (handler exn)
-                (raise-exception
-                 ((record-constructor &non-continuable)))))))))))
+      (let ((current-epoch (fluid-ref %exception-epoch)))
+        (let lp ((depth 0))
+          ;; FIXME: fluid-ref* takes time proportional to depth, which
+          ;; makes this loop quadratic.
+          (let ((val (fluid-ref* %exception-handler depth)))
+            ;; There are two types of exception handlers: unwinding handlers
+            ;; and pre-unwind handlers.  Although you can implement unwinding
+            ;; handlers with pre-unwind handlers, it's better to separate them
+            ;; because it allows for emergency situations like "stack
+            ;; overflow" or "out of memory" to unwind the stack before calling
+            ;; a handler.
+            (cond
+             ((not val)
+              ;; No exception handlers bound; use fallback.
+              (fallback-exception-handler exn))
+             ((fluid? (car val))
+              (let ((epoch (car val))
+                    (handler (cdr val)))
+                (cond
+                 ((< (fluid-ref epoch) current-epoch)
+                  (with-fluids ((epoch current-epoch))
+                    (cond
+                     (continuable?
+                      (handler exn))
+                     (else
+                      (handler exn)
+                      (raise-exception
+                       ((record-constructor &non-continuable)))))))
+                 (else
+                  (lp (1+ depth))))))
+             (else
+              (let ((prompt-tag (car val))
+                    (type (cdr val)))
+                (cond
+                 ((exception-has-type? exn type)
+                  (abort-to-prompt prompt-tag exn)
+                  (error "unreachable"))
+                 (else
+                  (lp (1+ depth)))))))))))
 
     (define* (with-exception-handler handler thunk #:key (unwind? #f)
                                      (unwind-for-type #t))
@@ -1748,8 +1750,9 @@ exceptions with the given @code{exception-kind} will be 
handled."
            (lambda (k exn)
              (handler exn)))))
        (else
-        (with-fluids ((%exception-handler handler))
-          (thunk)))))
+        (let ((epoch (make-fluid 0)))
+          (with-fluids ((%exception-handler (cons epoch handler)))
+            (thunk))))))
 
     (define (throw key . args)
       "Invoke the catch form matching @var{key}, passing @var{args} to the
@@ -1771,11 +1774,30 @@ for key @var{k}, then invoke @var{thunk}."
                    "Wrong type argument in position ~a: ~a"
                    (list 1 k) (list k)))
       (define running? (make-fluid))
+      ;; Throw handlers have two semantic oddities.
+      ;;
+      ;; One is that throw handlers are not re-entrant: if one is
+      ;; already active in the current continuation, it won't handle
+      ;; exceptions thrown within that continuation.  It's a restrictive
+      ;; choice, but it does ensure progress.  We ensure this property
+      ;; by having a running? fluid associated with each
+      ;; with-throw-handler.
+      ;;
+      ;; The other oddity is that any exception thrown within a throw
+      ;; handler starts the whole raise-exception dispatch procedure
+      ;; again from the top.  This can have its uses if you want to have
+      ;; handlers for multiple specific keys active at the same time,
+      ;; without specifying an order between them.  But, it's weird.  We
+      ;; ensure this property by having a %exception-epoch fluid and
+      ;; also associating an epoch with each pre-unwind handler; a
+      ;; handler is active if its epoch is less than the current
+      ;; %exception-epoch.  We increment the epoch with the extent of
+      ;; the throw handler.
       (with-exception-handler
        (lambda (exn)
          (when (and (or (eq? k #t) (eq? k (exception-kind exn)))
                     (not (fluid-ref running?)))
-           (with-fluids ((%active-exception-handlers #f)
+           (with-fluids ((%exception-epoch (1+ (fluid-ref %exception-epoch)))
                          (running? #t))
              (apply pre-unwind-handler (exception-kind exn)
                     (exception-args exn))))
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index 291e10e26..fbd6ad5fa 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -17,6 +17,7 @@
 
 
 (define-module (test-suite exceptions)
+  #:use-module (ice-9 control)
   #:use-module (test-suite lib))
 
 (define-syntax-parameter push
@@ -392,3 +393,14 @@
       (let* ((thunk1 (catch* 'foo (lambda () (throw 'bar))))
              (thunk2 (catch* 'bar (lambda () (thunk1)))))
         (thunk2))))
+
+(with-test-prefix "throwing within exception handlers"
+  (pass-if "https://github.com/wingo/fibers/issues/76";
+    (let/ec return
+      (with-exception-handler
+          (lambda (e)
+            (catch #t
+              (lambda () (error "bar"))
+              (lambda args #f))
+            (return #t))
+        (lambda () (error "foo"))))))