[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Avoid stacks in dynamically-bound values
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Avoid stacks in dynamically-bound values |
|
Date: |
Tue, 7 Feb 2017 08:58:34 +0000 (UTC) |
wingo pushed a commit to branch master
in repository guile.
commit 498f3f95684361f3591106a8f9cb9065fd649288
Author: Andy Wingo <address@hidden>
Date: Tue Feb 7 09:28:39 2017 +0100
Avoid stacks in dynamically-bound values
* libguile/dynstack.h:
* libguile/dynstack.c (scm_dynstack_find_old_fluid_value): New
function.
* libguile/fluids.c (saved_dynamic_state_ref): New helper.
(scm_fluid_ref): Fix docstring.
(scm_fluid_ref_star): New function allowing access to previous values
for a fluid.
(scm_dynamic_state_ref): New internal function.
* libguile/fluids.h: Add scm_fluid_ref_star and scm_dynamic_state_ref.
* libguile/stacks.c (scm_stack_id): Adapt to %stacks not being a chain.
* libguile/throw.c (catch, throw_without_pre_unwind): Adapt to
%exception-handlers not being a chain.
* module/ice-9/boot-9.scm (catch, dispatch-exception): Instead of having
%exception-handlers be a chain, use fluid-ref* to access the chain
that is in place at the time the exception is thrown. Prevents
unintended undelimited capture of the current exception handler stack
by a delimited "catch".
(%start-stack): Similarly, don't be a chain.
* module/system/repl/debug.scm (frame->stack-vector):
* module/system/repl/error-handling.scm (call-with-error-handling):
* module/ice-9/save-stack.scm (save-stack): Adapt to %stacks not being a
chain.
* test-suite/tests/exceptions.test ("delimited exception handlers"): Add
tests.
* doc/ref/api-control.texi (Fluids and Dynamic States): Add docs.
---
doc/ref/api-control.texi | 15 +++++
libguile/dynstack.c | 49 ++++++++++++++++
libguile/dynstack.h | 3 +
libguile/fluids.c | 47 +++++++++++++++-
libguile/fluids.h | 2 +
libguile/stacks.c | 2 +-
libguile/throw.c | 28 ++++-----
module/ice-9/boot-9.scm | 100 ++++++++++++++++++---------------
module/ice-9/save-stack.scm | 2 +-
module/system/repl/debug.scm | 4 +-
module/system/repl/error-handling.scm | 6 +-
test-suite/tests/exceptions.test | 30 +++++++++-
12 files changed, 221 insertions(+), 67 deletions(-)
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index 73fbe36..77d98b4 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -1765,6 +1765,21 @@ a runtime error.
Set the value associated with @var{fluid} in the current dynamic root.
@end deffn
address@hidden {Scheme Procedure} fluid-ref* fluid depth
address@hidden {C Function} scm_fluid_ref_star (fluid, depth)
+Return the @var{depth}th oldest value associated with @var{fluid} in the
+current thread. If @var{depth} equals or exceeds the number of values
+that have been assigned to @var{fluid}, return the default value of the
+fluid. @code{(fluid-ref* f 0)} is equivalent to @code{(fluid-ref f)}.
+
address@hidden is useful when you want to maintain a stack-like
+structure in a fluid, such as the stack of current exception handlers.
+Using @code{fluid-ref*} instead of an explicit stack allows any partial
+continuation captured by @code{call-with-prompt} to only capture the
+bindings made within the limits of the prompt instead of the entire
+continuation. @xref{Prompts}, for more on delimited continuations.
address@hidden deffn
+
@deffn {Scheme Procedure} fluid-unset! fluid
@deffnx {C Function} scm_fluid_unset_x (fluid)
Disassociate the given fluid from any value, making it unbound.
diff --git a/libguile/dynstack.c b/libguile/dynstack.c
index ff57c43..652d2b3 100644
--- a/libguile/dynstack.c
+++ b/libguile/dynstack.c
@@ -504,6 +504,55 @@ scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM
key,
return NULL;
}
+SCM
+scm_dynstack_find_old_fluid_value (scm_t_dynstack *dynstack, SCM fluid,
+ size_t depth, SCM dflt)
+{
+ scm_t_bits *walk;
+
+ for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk;
+ walk = SCM_DYNSTACK_PREV (walk))
+ {
+ scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
+
+ switch (SCM_DYNSTACK_TAG_TYPE (tag))
+ {
+ case SCM_DYNSTACK_TYPE_WITH_FLUID:
+ {
+ if (scm_is_eq (WITH_FLUID_FLUID (walk), fluid))
+ {
+ if (depth == 0)
+ return SCM_VARIABLE_REF (WITH_FLUID_VALUE_BOX (walk));
+ else
+ depth--;
+ }
+ break;
+ }
+ case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
+ {
+ SCM state, val;
+
+ /* The previous dynamic state may or may not have
+ established a binding for this fluid. */
+ state = scm_variable_ref (DYNAMIC_STATE_STATE_BOX (walk));
+ val = scm_dynamic_state_ref (state, fluid, SCM_UNDEFINED);
+ if (!SCM_UNBNDP (val))
+ {
+ if (depth == 0)
+ return val;
+ else
+ depth--;
+ }
+ break;
+ }
+ default:
+ break;
+ }
+ }
+
+ return dflt;
+}
+
void
scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item,
scm_t_ptrdiff reloc, scm_i_jmp_buf *registers)
diff --git a/libguile/dynstack.h b/libguile/dynstack.h
index 9d91fb6..7e191fc 100644
--- a/libguile/dynstack.h
+++ b/libguile/dynstack.h
@@ -201,6 +201,9 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt
(scm_t_dynstack *, SCM,
scm_t_uint32 **,
scm_i_jmp_buf **);
+SCM_INTERNAL SCM scm_dynstack_find_old_fluid_value (scm_t_dynstack *,
+ SCM, size_t, SCM);
+
SCM_INTERNAL void scm_dynstack_wind_prompt (scm_t_dynstack *, scm_t_bits *,
scm_t_ptrdiff, scm_i_jmp_buf *);
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 72c7595..7daad77 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -148,6 +148,16 @@ save_dynamic_state (scm_t_dynamic_state *state)
}
static SCM
+saved_dynamic_state_ref (SCM saved, SCM fluid, SCM dflt)
+{
+ for (; scm_is_pair (saved); saved = SCM_CDR (saved))
+ if (scm_is_eq (SCM_CAAR (saved), fluid))
+ return SCM_CDAR (saved);
+
+ return scm_weak_table_refq (saved, fluid, dflt);
+}
+
+static SCM
add_entry (void *data, SCM k, SCM v, SCM result)
{
scm_weak_table_putq_x (result, k, v);
@@ -300,7 +310,7 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
(SCM fluid),
"Return the value associated with @var{fluid} in the current\n"
"dynamic root. If @var{fluid} has not been set, then return\n"
- "@code{#f}.")
+ "its default value.")
#define FUNC_NAME s_scm_fluid_ref
{
SCM ret;
@@ -312,6 +322,33 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_fluid_ref_star, "fluid-ref*", 2, 0, 0,
+ (SCM fluid, SCM depth),
+ "Return the @var{depth}th oldest value associated with\n"
+ "@var{fluid} in the current thread. If @var{depth} equals\n"
+ "or exceeds the number of values that have been assigned to\n"
+ "@var{fluid}, return the default value of the fluid.")
+#define FUNC_NAME s_scm_fluid_ref_star
+{
+ SCM ret;
+ size_t c_depth;
+
+ SCM_VALIDATE_FLUID (1, fluid);
+ c_depth = SCM_NUM2SIZE (2, depth);
+
+ if (c_depth == 0)
+ ret = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid);
+ else
+ ret = scm_dynstack_find_old_fluid_value (&SCM_I_CURRENT_THREAD->dynstack,
+ fluid, c_depth - 1,
+ SCM_I_FLUID_DEFAULT (fluid));
+
+ if (SCM_UNBNDP (ret))
+ scm_misc_error ("fluid-ref*", "unbound fluid: ~S", scm_list_1 (fluid));
+ return ret;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
(SCM fluid, SCM value),
"Set the value associated with @var{fluid} in the current dynamic
root.")
@@ -499,6 +536,14 @@ SCM_DEFINE (scm_set_current_dynamic_state,
"set-current-dynamic-state", 1,0,0,
}
#undef FUNC_NAME
+SCM
+scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt)
+{
+ SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1,
+ "dynamic-state-ref");
+ return saved_dynamic_state_ref (get_dynamic_state (state), fluid, dflt);
+}
+
static void
swap_dynamic_state (SCM loc)
{
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 8031c0d..6d7969e 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -56,6 +56,7 @@ SCM_API SCM scm_make_unbound_fluid (void);
SCM_API int scm_is_fluid (SCM obj);
SCM_API SCM scm_fluid_p (SCM fl);
SCM_API SCM scm_fluid_ref (SCM fluid);
+SCM_API SCM scm_fluid_ref_star (SCM fluid, SCM depth);
SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
SCM_API SCM scm_fluid_unset_x (SCM fluid);
SCM_API SCM scm_fluid_bound_p (SCM fluid);
@@ -80,6 +81,7 @@ SCM_API void scm_dynwind_current_dynamic_state (SCM state);
SCM_API void *scm_c_with_dynamic_state (SCM state,
void *(*func)(void *), void *data);
SCM_API SCM scm_with_dynamic_state (SCM state, SCM proc);
+SCM_INTERNAL SCM scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt);
SCM_INTERNAL SCM scm_i_make_initial_dynamic_state (void);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 3d02d81..99ee233 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -414,7 +414,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
{
/* Fetch most recent start-stack tag. */
SCM stacks = scm_fluid_ref (scm_sys_stacks);
- return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
+ return scm_is_pair (stacks) ? scm_car (stacks) : SCM_BOOL_F;
}
else if (SCM_CONTINUATIONP (stack))
/* FIXME: implement me */
diff --git a/libguile/throw.c b/libguile/throw.c
index c3a4616..5f6dcfa 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -96,11 +96,10 @@ catch (SCM tag, SCM thunk, SCM handler, SCM
pre_unwind_handler)
prompt_tag = scm_cons (SCM_INUM0, SCM_EOL);
- eh = scm_c_make_vector (4, SCM_BOOL_F);
- scm_c_vector_set_x (eh, 0, scm_fluid_ref (exception_handler_fluid));
- scm_c_vector_set_x (eh, 1, tag);
- scm_c_vector_set_x (eh, 2, prompt_tag);
- scm_c_vector_set_x (eh, 3, pre_unwind_handler);
+ eh = scm_c_make_vector (3, SCM_BOOL_F);
+ scm_c_vector_set_x (eh, 0, tag);
+ scm_c_vector_set_x (eh, 1, prompt_tag);
+ scm_c_vector_set_x (eh, 2, pre_unwind_handler);
vp = scm_the_vm ();
prev_cookie = vp->resumable_prompt_cookie;
@@ -201,23 +200,26 @@ abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
static SCM
throw_without_pre_unwind (SCM tag, SCM args)
{
- SCM eh;
+ size_t depth = 0;
/* This function is not only the boot implementation of "throw", it is
also called in response to resource allocation failures such as
stack-overflow or out-of-memory. For that reason we need to be
careful to avoid allocating memory. */
- for (eh = scm_fluid_ref (exception_handler_fluid);
- scm_is_true (eh);
- eh = scm_c_vector_ref (eh, 0))
+ while (1)
{
- SCM catch_key, prompt_tag;
+ SCM eh, catch_key, prompt_tag;
- catch_key = scm_c_vector_ref (eh, 1);
+ eh = scm_fluid_ref_star (exception_handler_fluid,
+ scm_from_size_t (depth++));
+ if (scm_is_false (eh))
+ break;
+
+ catch_key = scm_c_vector_ref (eh, 0);
if (!scm_is_eq (catch_key, SCM_BOOL_T) && !scm_is_eq (catch_key, tag))
continue;
- if (scm_is_true (scm_c_vector_ref (eh, 3)))
+ if (scm_is_true (scm_c_vector_ref (eh, 2)))
{
const char *key_chars;
@@ -230,7 +232,7 @@ throw_without_pre_unwind (SCM tag, SCM args)
"skipping pre-unwind handler.\n", key_chars);
}
- prompt_tag = scm_c_vector_ref (eh, 2);
+ prompt_tag = scm_c_vector_ref (eh, 1);
if (scm_is_true (prompt_tag))
abort_to_prompt (prompt_tag, tag, args);
}
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 802ca77..229d917 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -720,48 +720,59 @@ information is unavailable."
(define with-throw-handler #f)
(let ((%eh (module-ref (current-module) '%exception-handler)))
(define (make-exception-handler catch-key prompt-tag pre-unwind)
- (vector (fluid-ref %eh) catch-key prompt-tag pre-unwind))
- (define (exception-handler-prev handler) (vector-ref handler 0))
- (define (exception-handler-catch-key handler) (vector-ref handler 1))
- (define (exception-handler-prompt-tag handler) (vector-ref handler 2))
- (define (exception-handler-pre-unwind handler) (vector-ref handler 3))
-
- (define %running-pre-unwind (make-fluid '()))
-
- (define (dispatch-exception handler key args)
- (unless handler
- (when (eq? key 'quit)
- (primitive-exit (cond
- ((not (pair? args)) 0)
- ((integer? (car args)) (car args))
- ((not (car args)) 1)
- (else 0))))
- (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key
args)
- (primitive-exit 1))
-
- (let ((catch-key (exception-handler-catch-key handler))
- (prev (exception-handler-prev handler)))
- (if (or (eqv? catch-key #t) (eq? catch-key key))
- (let ((prompt-tag (exception-handler-prompt-tag handler))
- (pre-unwind (exception-handler-pre-unwind handler)))
- (if pre-unwind
- ;; Instead of using a "running" set, it would be a lot
- ;; cleaner semantically to roll back the exception
- ;; handler binding to the one that was in place when the
- ;; pre-unwind handler was installed, and keep it like
- ;; that for the rest of the dispatch. Unfortunately
- ;; that is incompatible with existing semantics. We'll
- ;; see if we can change that later on.
- (let ((running (fluid-ref %running-pre-unwind)))
- (with-fluid* %running-pre-unwind (cons handler running)
- (lambda ()
- (unless (memq handler running)
- (apply pre-unwind key args))
- (if prompt-tag
- (apply abort-to-prompt prompt-tag key args)
- (dispatch-exception prev key args)))))
- (apply abort-to-prompt prompt-tag key args)))
- (dispatch-exception prev key args))))
+ (vector catch-key prompt-tag pre-unwind))
+ (define (exception-handler-catch-key handler) (vector-ref handler 0))
+ (define (exception-handler-prompt-tag handler) (vector-ref handler 1))
+ (define (exception-handler-pre-unwind handler) (vector-ref handler 2))
+
+ (define %running-pre-unwind (make-fluid #f))
+ (define (pre-unwind-handler-running? handler)
+ (let lp ((depth 0))
+ (let ((running (fluid-ref* %running-pre-unwind depth)))
+ (and running
+ (or (eq? running handler) (lp (1+ depth)))))))
+
+ (define (dispatch-exception depth key args)
+ (cond
+ ((fluid-ref* %eh depth)
+ => (lambda (handler)
+ (let ((catch-key (exception-handler-catch-key handler)))
+ (if (or (eqv? catch-key #t) (eq? catch-key key))
+ (let ((prompt-tag (exception-handler-prompt-tag handler))
+ (pre-unwind (exception-handler-pre-unwind handler)))
+ (cond
+ ((and pre-unwind
+ (not (pre-unwind-handler-running? handler)))
+ ;; Prevent errors from within the pre-unwind
+ ;; handler's invocation from being handled by this
+ ;; handler.
+ (with-fluid* %running-pre-unwind handler
+ (lambda ()
+ ;; FIXME: Currently the "running" flag only
+ ;; applies to the pre-unwind handler; the
+ ;; post-unwind handler is still called if the
+ ;; error is explicitly rethrown. Instead it
+ ;; would be better to cause a recursive throw to
+ ;; skip all parts of this handler. Unfortunately
+ ;; that is incompatible with existing semantics.
+ ;; We'll see if we can change that later on.
+ (apply pre-unwind key args)
+ (dispatch-exception depth key args))))
+ (prompt-tag
+ (apply abort-to-prompt prompt-tag key args))
+ (else
+ (dispatch-exception (1+ depth) key args))))
+ (dispatch-exception (1+ depth) key args)))))
+ ((eq? key 'quit)
+ (primitive-exit (cond
+ ((not (pair? args)) 0)
+ ((integer? (car args)) (car args))
+ ((not (car args)) 1)
+ (else 0))))
+ (else
+ (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+ key args)
+ (primitive-exit 1))))
(define (throw key . args)
"Invoke the catch form matching @var{key}, passing @var{args} to the
@@ -773,7 +784,7 @@ If there is no handler at all, Guile prints an error and
then exits."
(unless (symbol? key)
(throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
(list 1 key) (list key)))
- (dispatch-exception (fluid-ref %eh) key args))
+ (dispatch-exception 0 key args))
(define* (catch k thunk handler #:optional pre-unwind-handler)
"Invoke @var{thunk} in the dynamic context of @var{handler} for
@@ -1681,8 +1692,7 @@ written into the port is returned."
(call-with-prompt
prompt-tag
(lambda ()
- (with-fluids ((%stacks (acons tag prompt-tag
- (or (fluid-ref %stacks) '()))))
+ (with-fluids ((%stacks (cons tag prompt-tag)))
(thunk)))
(lambda (k . args)
(%start-stack tag (lambda () (apply k args)))))))
diff --git a/module/ice-9/save-stack.scm b/module/ice-9/save-stack.scm
index 8ba0067..5abd1d8 100644
--- a/module/ice-9/save-stack.scm
+++ b/module/ice-9/save-stack.scm
@@ -53,6 +53,6 @@
;; if any.
(apply make-stack #t
2
- (if (pair? stacks) (cdar stacks) 0)
+ (if (pair? stacks) (cdr stacks) 0)
narrowing)))
(set! stack-saved? #t))))
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 55062d7..383d379 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -184,7 +184,7 @@
(define (frame->stack-vector frame)
(let ((stack (make-stack frame)))
(match (fluid-ref %stacks)
- (((stack-tag . prompt-tag) . _)
+ ((stack-tag . prompt-tag)
(narrow-stack->vector
stack
;; Take the stack from the given frame, cutting 0 frames.
@@ -206,5 +206,5 @@
;; 2
;; ;; Narrow the end of the stack to the most recent start-stack.
;; (and (pair? (fluid-ref %stacks))
-;; (cdar (fluid-ref %stacks))))))
+;; (cdr (fluid-ref %stacks))))))
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index 94a9f2a..8d5a8a5 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -57,7 +57,7 @@
(define (debug-trap-handler frame trap-idx trap-name)
(let* ((tag (and (pair? (fluid-ref %stacks))
- (cdar (fluid-ref %stacks))))
+ (cdr (fluid-ref %stacks))))
(stack (narrow-stack->vector
(make-stack frame)
;; Take the stack from the given frame, cutting 0
@@ -132,7 +132,7 @@
(lambda (key . args)
(if (not (memq key pass-keys))
(let* ((tag (and (pair? (fluid-ref %stacks))
- (cdar (fluid-ref %stacks))))
+ (cdr (fluid-ref %stacks))))
(stack (narrow-stack->vector
(make-stack #t)
;; Cut three frames from the top of the stack:
@@ -161,7 +161,7 @@
(lambda (key . args)
(if (not (memq key pass-keys))
(let* ((tag (and (pair? (fluid-ref %stacks))
- (cdar (fluid-ref %stacks))))
+ (cdr (fluid-ref %stacks))))
(frames (narrow-stack->vector
(make-stack #t)
;; Narrow as above, for the debugging case.
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index a839b68..391a19d 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -16,7 +16,8 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(use-modules (test-suite lib))
+(define-module (test-suite exceptions)
+ #:use-module (test-suite lib))
(define-syntax-parameter push
(lambda (stx)
@@ -365,3 +366,30 @@
;; (not (eval `(,false-if-exception (,error "xxx"))
;; empty-environment))))
)
+
+(with-test-prefix "delimited exception handlers"
+ (define (catch* key thunk)
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt tag
+ (lambda ()
+ (catch key
+ (lambda ()
+ (abort-to-prompt tag)
+ (thunk))
+ (lambda args args)))
+ (lambda (k) k))))
+ (pass-if-equal '(foo)
+ (let ((thunk (catch* 'foo (lambda () (throw 'foo)))))
+ (thunk)))
+ (pass-if-equal '(foo)
+ (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo))))
+ (thunk2 (catch* 'bar (lambda () (thunk1)))))
+ (thunk1)))
+ (pass-if-equal '(foo)
+ (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo))))
+ (thunk2 (catch* 'bar (lambda () (thunk1)))))
+ (thunk2)))
+ (pass-if-equal '(bar)
+ (let* ((thunk1 (catch* 'foo (lambda () (throw 'bar))))
+ (thunk2 (catch* 'bar (lambda () (thunk1)))))
+ (thunk2))))