From 02dfb6e7767c4946daa2aef1985007128f35351f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 7 Jun 2023 22:26:05 +0200 Subject: [PATCH] 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"))))))