[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 18/18: Fix exn dispatch for exns within pre-unwind handl
From: |
Andy Wingo |
Subject: |
[Guile-commits] 18/18: Fix exn dispatch for exns within pre-unwind handlers |
Date: |
Thu, 8 Jun 2023 04:26:43 -0400 (EDT) |
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"))))))
- [Guile-commits] 05/18: Add "custom ports", (continued)
- [Guile-commits] 05/18: Add "custom ports", Andy Wingo, 2023/06/08
- [Guile-commits] 06/18: Rewrite custom binary ports in Scheme, in terms of custom ports, Andy Wingo, 2023/06/08
- [Guile-commits] 08/18: Rewrite soft ports in Scheme, Andy Wingo, 2023/06/08
- [Guile-commits] 04/18: bytevector-slice: optimize trivial case, Andy Wingo, 2023/06/08
- [Guile-commits] 16/18: Load (ice-9 binary-ports) from C in thread-safe way, Andy Wingo, 2023/06/08
- [Guile-commits] 07/18: Use custom binary output ports for make-chunked-output-port, Andy Wingo, 2023/06/08
- [Guile-commits] 13/18: Inline generic-write into pretty-print, Andy Wingo, 2023/06/08
- [Guile-commits] 10/18: Modernize soft ports, Andy Wingo, 2023/06/08
- [Guile-commits] 01/18: pretty-print: Use string-concatenate-reverse, Andy Wingo, 2023/06/08
- [Guile-commits] 17/18: Deprecate (ice-9 lineio), Andy Wingo, 2023/06/08
- [Guile-commits] 18/18: Fix exn dispatch for exns within pre-unwind handlers,
Andy Wingo <=
- [Guile-commits] 09/18: Implement R6RS custom textual ports, Andy Wingo, 2023/06/08
- [Guile-commits] 11/18: Rewrite pretty-print to rely on port-column, abort early, Andy Wingo, 2023/06/08
- [Guile-commits] 14/18: truncated-print: use call-with-truncating-output-string, Andy Wingo, 2023/06/08
- [Guile-commits] 12/18: pretty-print: width arg is never false, Andy Wingo, 2023/06/08
- [Guile-commits] 15/18: Fix allow-newline? in call-with-truncating-output-string, Andy Wingo, 2023/06/08
- [Guile-commits] 02/18: pretty-print: inline genwrite:newline-str, Andy Wingo, 2023/06/08