mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Avoid stacks in dynamically-bound values

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-02-07 09:28:39 +01:00
parent 81e9a128c1
commit 498f3f9568
12 changed files with 219 additions and 65 deletions
Download patch file Download diff file Expand all files Collapse all files

15
doc/ref/api-control.texi
View file

@ -1765,6 +1765,21 @@ a runtime error.
Set the value associated with @var{fluid} in the current dynamic root.
@end deffn
@deffn {Scheme Procedure} fluid-ref* fluid depth
@deffnx {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)}.
@code{fluid-ref*} 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.
@end 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.

49
libguile/dynstack.c
View file

@ -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)

3
libguile/dynstack.h
View file

@ -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 *);

47
libguile/fluids.c
View file

@ -147,6 +147,16 @@ save_dynamic_state (scm_t_dynamic_state *state)
return saved;
}
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)
{
@ -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)
{

2
libguile/fluids.h
View file

@ -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);

2
libguile/stacks.c
View file

@ -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 */

28
libguile/throw.c
View file

@ -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);
}

86
module/ice-9/boot-9.scm
View file

@ -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))
(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 '()))
(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 handler key args)
(unless handler
(when (eq? key 'quit)
(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))))
(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))))
(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)))))))

2
module/ice-9/save-stack.scm
View file

@ -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))))

4
module/system/repl/debug.scm
View file

@ -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))))))

6
module/system/repl/error-handling.scm
View file

@ -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.

30
test-suite/tests/exceptions.test
View file

@ -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))))