mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-17 09:10:22 +02:00
with-dynamic-state compiler and VM support
* libguile/dynstack.h (SCM_DYNSTACK_TYPE_DYNAMIC_STATE):
* libguile/dynstack.c (DYNAMIC_STATE_WORDS, DYNAMIC_STATE_STATE_BOX):
(scm_dynstack_push_dynamic_state):
(scm_dynstack_unwind_dynamic_state): New definitions.
(scm_dynstack_unwind_1, scm_dynstack_wind_1): Add with-dynamic-state
cases.
* libguile/memoize.c (push_dynamic_state, pop_dynamic_state)
(do_push_dynamic_state, do_pop_dynamic_state): New definitions.
(memoize, scm_init_memoize): Handle push-dynamic-state and
pop-dynamic-state.
* libguile/vm-engine.c (push-dynamic-state, pop-dynamic-state): New
opcodes.
* module/ice-9/boot-9.scm (with-dynamic-state): New definition in Scheme
so that the push-dynamic-state and pop-dynamic-state always run in the
VM.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm:
* module/language/cps/types.scm:
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/peval.scm (peval):
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
* module/system/vm/assembler.scm: Add support for with-dynamic-state to
the compiler.
* test-suite/tests/fluids.test ("dynamic states"): Add basic tests.
* doc/ref/vm.texi (Dynamic Environment Instructions): Update.
This commit is contained in:
Andy Wingo
parent
aa84489d18
commit
7184c176b4
14 changed files with 260 additions and 5 deletions
|
|
@ -1204,6 +1204,18 @@ Set the value of the fluid in @var{dst} to the value in @var{src}.
|
|||
Write the value of the current thread to @var{dst}.
|
||||
@end deftypefn
|
||||
|
||||
@deftypefn Instruction {} push-dynamic-state s24:@var{state}
|
||||
Save the current set of fluid bindings on the dynamic stack and instate
|
||||
the bindings from @var{state} instead. @xref{Fluids and Dynamic
|
||||
States}.
|
||||
@end deftypefn
|
||||
|
||||
@deftypefn Instruction {} pop-dynamic-state x24:@var{_}
|
||||
Restore a saved set of fluid bindings from the dynamic stack.
|
||||
@code{push-dynamic-state} should always be balanced with
|
||||
@code{pop-dynamic-state}.
|
||||
@end deftypefn
|
||||
|
||||
|
||||
@node Miscellaneous Instructions
|
||||
@subsubsection Miscellaneous Instructions
|
||||
|
|
@ -1237,6 +1249,17 @@ Pop the stack pointer by @var{count} words, discarding any values that
|
|||
were stored there.
|
||||
@end deftypefn
|
||||
|
||||
@deftypefn Instruction {} handle-interrupts x24:@var{_}
|
||||
Handle pending asynchronous interrupts (asyncs). @xref{Asyncs}. The
|
||||
compiler inserts @code{handle-interrupts} instructions before any call,
|
||||
return, or loop back-edge.
|
||||
@end deftypefn
|
||||
|
||||
@deftypefn Instruction {} return-from-interrupt x24:@var{_}
|
||||
A special instruction to return from a call and also pop off the stack
|
||||
frame from the call. Used when returning from asynchronous interrupts.
|
||||
@end deftypefn
|
||||
|
||||
|
||||
@node Inlined Scheme Instructions
|
||||
@subsubsection Inlined Scheme Instructions
|
||||
|
|
|
|||
|
|
@ -53,6 +53,9 @@
|
|||
#define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0]))
|
||||
#define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1]))
|
||||
|
||||
#define DYNAMIC_STATE_WORDS 1
|
||||
#define DYNAMIC_STATE_STATE_BOX(top) (SCM_PACK ((top)[0]))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -230,6 +233,22 @@ dynstack_pop (scm_t_dynstack *dynstack, scm_t_bits **words)
|
|||
return tag;
|
||||
}
|
||||
|
||||
void
|
||||
scm_dynstack_push_dynamic_state (scm_t_dynstack *dynstack, SCM state,
|
||||
scm_t_dynamic_state *dynamic_state)
|
||||
{
|
||||
scm_t_bits *words;
|
||||
SCM state_box;
|
||||
|
||||
if (SCM_UNLIKELY (scm_is_false (scm_dynamic_state_p (state))))
|
||||
scm_wrong_type_arg ("with-dynamic-state", 0, state);
|
||||
|
||||
state_box = scm_make_variable (scm_set_current_dynamic_state (state));
|
||||
words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNAMIC_STATE, 0,
|
||||
DYNAMIC_STATE_WORDS);
|
||||
words[0] = SCM_UNPACK (state_box);
|
||||
}
|
||||
|
||||
void
|
||||
scm_dynstack_pop (scm_t_dynstack *dynstack)
|
||||
{
|
||||
|
|
@ -305,6 +324,12 @@ scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item)
|
|||
scm_call_0 (DYNWIND_ENTER (item));
|
||||
break;
|
||||
|
||||
case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
|
||||
scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (item),
|
||||
scm_set_current_dynamic_state
|
||||
(scm_variable_ref (DYNAMIC_STATE_STATE_BOX (item))));
|
||||
break;
|
||||
|
||||
case SCM_DYNSTACK_TYPE_NONE:
|
||||
default:
|
||||
abort ();
|
||||
|
|
@ -362,6 +387,13 @@ scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
|
|||
}
|
||||
break;
|
||||
|
||||
case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
|
||||
scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (words),
|
||||
scm_set_current_dynamic_state
|
||||
(scm_variable_ref (DYNAMIC_STATE_STATE_BOX (words))));
|
||||
clear_scm_t_bits (words, DYNAMIC_STATE_WORDS);
|
||||
break;
|
||||
|
||||
case SCM_DYNSTACK_TYPE_NONE:
|
||||
default:
|
||||
abort ();
|
||||
|
|
@ -542,6 +574,25 @@ scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack,
|
|||
clear_scm_t_bits (words, len);
|
||||
}
|
||||
|
||||
void
|
||||
scm_dynstack_unwind_dynamic_state (scm_t_dynstack *dynstack,
|
||||
scm_t_dynamic_state *dynamic_state)
|
||||
{
|
||||
scm_t_bits tag, *words;
|
||||
size_t len;
|
||||
|
||||
tag = dynstack_pop (dynstack, &words);
|
||||
len = SCM_DYNSTACK_TAG_LEN (tag);
|
||||
|
||||
assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_DYNAMIC_STATE);
|
||||
assert (len == DYNAMIC_STATE_WORDS);
|
||||
|
||||
scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (words),
|
||||
scm_set_current_dynamic_state
|
||||
(scm_variable_ref (DYNAMIC_STATE_STATE_BOX (words))));
|
||||
clear_scm_t_bits (words, len);
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
|
|
|
|||
|
|
@ -81,6 +81,7 @@ typedef enum {
|
|||
SCM_DYNSTACK_TYPE_WITH_FLUID,
|
||||
SCM_DYNSTACK_TYPE_PROMPT,
|
||||
SCM_DYNSTACK_TYPE_DYNWIND,
|
||||
SCM_DYNSTACK_TYPE_DYNAMIC_STATE,
|
||||
} scm_t_dynstack_item_type;
|
||||
|
||||
#define SCM_DYNSTACK_TAG_TYPE_MASK 0xf
|
||||
|
|
@ -150,6 +151,8 @@ SCM_INTERNAL void scm_dynstack_push_unwinder (scm_t_dynstack *,
|
|||
SCM_INTERNAL void scm_dynstack_push_fluid (
|
||||
scm_t_dynstack *, SCM fluid, SCM value,
|
||||
scm_t_dynamic_state *dynamic_state);
|
||||
SCM_INTERNAL void scm_dynstack_push_dynamic_state (scm_t_dynstack *, SCM,
|
||||
scm_t_dynamic_state *);
|
||||
SCM_INTERNAL void scm_dynstack_push_prompt (scm_t_dynstack *,
|
||||
scm_t_dynstack_prompt_flags,
|
||||
SCM key,
|
||||
|
|
@ -188,6 +191,8 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_unwind_fork (scm_t_dynstack *,
|
|||
SCM_INTERNAL void scm_dynstack_unwind_frame (scm_t_dynstack *);
|
||||
SCM_INTERNAL void scm_dynstack_unwind_fluid
|
||||
(scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state);
|
||||
SCM_INTERNAL void scm_dynstack_unwind_dynamic_state
|
||||
(scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state);
|
||||
|
||||
SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM,
|
||||
scm_t_dynstack_prompt_flags *,
|
||||
|
|
|
|||
|
|
@ -68,6 +68,8 @@ static SCM wind;
|
|||
static SCM unwind;
|
||||
static SCM push_fluid;
|
||||
static SCM pop_fluid;
|
||||
static SCM push_dynamic_state;
|
||||
static SCM pop_dynamic_state;
|
||||
|
||||
static SCM
|
||||
do_wind (SCM in, SCM out)
|
||||
|
|
@ -100,6 +102,24 @@ do_pop_fluid (void)
|
|||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
||||
static SCM
|
||||
do_push_dynamic_state (SCM state)
|
||||
{
|
||||
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
|
||||
scm_dynstack_push_dynamic_state (&thread->dynstack, state,
|
||||
thread->dynamic_state);
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
||||
static SCM
|
||||
do_pop_dynamic_state (void)
|
||||
{
|
||||
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
|
||||
scm_dynstack_unwind_dynamic_state (&thread->dynstack,
|
||||
thread->dynamic_state);
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -482,6 +502,14 @@ memoize (SCM exp, SCM env)
|
|||
else if (nargs == 0
|
||||
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
|
||||
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL);
|
||||
else if (nargs == 1
|
||||
&& scm_is_eq (name,
|
||||
scm_from_latin1_symbol ("push-dynamic-state")))
|
||||
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args);
|
||||
else if (nargs == 0
|
||||
&& scm_is_eq (name,
|
||||
scm_from_latin1_symbol ("pop-dynamic-state")))
|
||||
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL);
|
||||
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
|
||||
return MAKMEMO_CALL (maybe_makmemo_capture_module
|
||||
(MAKMEMO_BOX_REF
|
||||
|
|
@ -869,6 +897,10 @@ scm_init_memoize ()
|
|||
unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
|
||||
push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
|
||||
pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
|
||||
push_dynamic_state = scm_c_make_gsubr ("push-dynamic_state", 1, 0, 0,
|
||||
do_push_dynamic_state);
|
||||
pop_dynamic_state = scm_c_make_gsubr ("pop-dynamic_state", 0, 0, 0,
|
||||
do_pop_dynamic_state);
|
||||
|
||||
list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -3921,8 +3921,35 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
NEXT (0);
|
||||
}
|
||||
|
||||
VM_DEFINE_OP (185, unused_185, NULL, NOP)
|
||||
VM_DEFINE_OP (186, unused_186, NULL, NOP)
|
||||
/* push-dynamic-state state:24
|
||||
*
|
||||
* Save the current fluid bindings on the dynamic stack, and use STATE
|
||||
* instead.
|
||||
*/
|
||||
VM_DEFINE_OP (185, push_dynamic_state, "push-dynamic-state", OP1 (X8_S24))
|
||||
{
|
||||
scm_t_uint32 state;
|
||||
|
||||
UNPACK_24 (op, state);
|
||||
|
||||
SYNC_IP ();
|
||||
scm_dynstack_push_dynamic_state (&thread->dynstack, SP_REF (state),
|
||||
thread->dynamic_state);
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
/* pop-dynamic-state _:24
|
||||
*
|
||||
* Restore the saved fluid bindings from the dynamic stack.
|
||||
*/
|
||||
VM_DEFINE_OP (186, pop_dynamic_state, "pop-dynamic-state", OP1 (X32))
|
||||
{
|
||||
SYNC_IP ();
|
||||
scm_dynstack_unwind_dynamic_state (&thread->dynstack,
|
||||
thread->dynamic_state);
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
VM_DEFINE_OP (187, unused_187, NULL, NOP)
|
||||
VM_DEFINE_OP (188, unused_188, NULL, NOP)
|
||||
VM_DEFINE_OP (189, unused_189, NULL, NOP)
|
||||
|
|
|
|||
|
|
@ -154,6 +154,15 @@ a-cont
|
|||
((@@ primitive pop-fluid))
|
||||
(apply values vals))))
|
||||
|
||||
(define (with-dynamic-state state thunk)
|
||||
"Call @var{proc} while @var{state} is the current dynamic state object.
|
||||
@var{thunk} must be a procedure of no arguments."
|
||||
((@@ primitive push-dynamic-state) state)
|
||||
(call-with-values thunk
|
||||
(lambda vals
|
||||
((@@ primitive pop-dynamic-state))
|
||||
(apply values vals))))
|
||||
|
||||
|
||||
|
||||
;;; {Simple Debugging Tools}
|
||||
|
|
|
|||
|
|
@ -330,6 +330,10 @@
|
|||
(emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val))))
|
||||
(($ $primcall 'pop-fluid ())
|
||||
(emit-pop-fluid asm))
|
||||
(($ $primcall 'push-dynamic-state (state))
|
||||
(emit-push-dynamic-state asm (from-sp (slot state))))
|
||||
(($ $primcall 'pop-dynamic-state ())
|
||||
(emit-pop-dynamic-state asm))
|
||||
(($ $primcall 'wind (winder unwinder))
|
||||
(emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder))))
|
||||
(($ $primcall 'bv-u8-set! (bv idx val))
|
||||
|
|
|
|||
|
|
@ -287,7 +287,9 @@ is or might be a read or a write to the same location as A."
|
|||
((fluid-ref f) (&read-object &fluid) &type-check)
|
||||
((fluid-set! f v) (&write-object &fluid) &type-check)
|
||||
((push-fluid f v) (&write-object &fluid) &type-check)
|
||||
((pop-fluid) (&write-object &fluid) &type-check))
|
||||
((pop-fluid) (&write-object &fluid))
|
||||
((push-dynamic-state state) (&write-object &fluid) &type-check)
|
||||
((pop-dynamic-state) (&write-object &fluid)))
|
||||
|
||||
;; Threads. Calls cause &all-effects, which reflects the fact that any
|
||||
;; call can capture a partial continuation and reinstate it on another
|
||||
|
|
|
|||
|
|
@ -558,7 +558,9 @@ minimum, and maximum."
|
|||
((fluid-ref (&fluid 1)) &all-types)
|
||||
((fluid-set! (&fluid 0 1) &all-types))
|
||||
((push-fluid (&fluid 0 1) &all-types))
|
||||
((pop-fluid)))
|
||||
((pop-fluid))
|
||||
((push-dynamic-state &all-types))
|
||||
((pop-dynamic-state)))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -360,6 +360,14 @@ of an expression."
|
|||
(($ <primcall> _ 'pop-fluid ())
|
||||
(logior (cause &fluid)))
|
||||
|
||||
(($ <primcall> _ 'push-dynamic-state (state))
|
||||
(logior (compute-effects state)
|
||||
(cause &type-check)
|
||||
(cause &fluid)))
|
||||
|
||||
(($ <primcall> _ 'pop-dynamic-state ())
|
||||
(logior (cause &fluid)))
|
||||
|
||||
(($ <primcall> _ 'car (x))
|
||||
(logior (compute-effects x)
|
||||
(cause &type-check)
|
||||
|
|
|
|||
|
|
@ -1219,6 +1219,19 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(make-call src thunk '())
|
||||
(make-primcall src 'pop-fluid '()))))))))
|
||||
|
||||
(($ <primcall> src 'with-dynamic-state (state thunk))
|
||||
(for-tail
|
||||
(with-temporaries
|
||||
src (list state thunk) 1 constant-expression?
|
||||
(match-lambda
|
||||
((state thunk)
|
||||
(make-seq src
|
||||
(make-primcall src 'push-dynamic-state (list state))
|
||||
(make-begin0 src
|
||||
(make-call src thunk '())
|
||||
(make-primcall src 'pop-dynamic-state
|
||||
'()))))))))
|
||||
|
||||
(($ <primcall> src 'values exps)
|
||||
(cond
|
||||
((null? exps)
|
||||
|
|
|
|||
|
|
@ -84,7 +84,7 @@
|
|||
|
||||
current-module define!
|
||||
|
||||
current-thread fluid-ref fluid-set! with-fluid*
|
||||
current-thread fluid-ref fluid-set! with-fluid* with-dynamic-state
|
||||
|
||||
call-with-prompt
|
||||
abort-to-prompt* abort-to-prompt
|
||||
|
|
|
|||
|
|
@ -122,6 +122,8 @@
|
|||
emit-unwind
|
||||
emit-push-fluid
|
||||
emit-pop-fluid
|
||||
emit-push-dynamic-state
|
||||
emit-pop-dynamic-state
|
||||
emit-current-thread
|
||||
emit-fluid-ref
|
||||
emit-fluid-set!
|
||||
|
|
|
|||
|
|
@ -184,3 +184,80 @@
|
|||
(catch #t
|
||||
(lambda () (fluid-ref fluid))
|
||||
(lambda (key . args) #t)))))
|
||||
|
||||
(with-test-prefix "dynamic states"
|
||||
(pass-if "basics"
|
||||
(dynamic-state? (current-dynamic-state)))
|
||||
|
||||
(pass-if "with a fluid (basic)"
|
||||
(let ((fluid (make-fluid #f))
|
||||
(state (current-dynamic-state)))
|
||||
(with-dynamic-state
|
||||
state
|
||||
(lambda ()
|
||||
(eqv? (fluid-ref fluid) #f)))))
|
||||
|
||||
(pass-if "with a fluid (set outer)"
|
||||
(let ((fluid (make-fluid #f))
|
||||
(state (current-dynamic-state)))
|
||||
(fluid-set! fluid #t)
|
||||
(and (with-dynamic-state
|
||||
state
|
||||
(lambda ()
|
||||
(eqv? (fluid-ref fluid) #f)))
|
||||
(eqv? (fluid-ref fluid) #t))))
|
||||
|
||||
(pass-if "with a fluid (set inner)"
|
||||
(let ((fluid (make-fluid #f))
|
||||
(state (current-dynamic-state)))
|
||||
(and (with-dynamic-state
|
||||
state
|
||||
(lambda ()
|
||||
(fluid-set! fluid #t)
|
||||
(eqv? (fluid-ref fluid) #t)))
|
||||
(eqv? (fluid-ref fluid) #f))))
|
||||
|
||||
(pass-if "dynstate captured (1)"
|
||||
(let ((fluid (make-fluid #f))
|
||||
(state (current-dynamic-state))
|
||||
(tag (make-prompt-tag "hey")))
|
||||
(let ((k (call-with-prompt tag
|
||||
(lambda ()
|
||||
(with-dynamic-state
|
||||
state
|
||||
(lambda ()
|
||||
(abort-to-prompt tag)
|
||||
(fluid-ref fluid))))
|
||||
(lambda (k) k))))
|
||||
(eqv? (k) #f))))
|
||||
|
||||
(pass-if "dynstate captured (2)"
|
||||
(let ((fluid (make-fluid #f))
|
||||
(state (current-dynamic-state))
|
||||
(tag (make-prompt-tag "hey")))
|
||||
(let ((k (call-with-prompt tag
|
||||
(lambda ()
|
||||
(with-dynamic-state
|
||||
state
|
||||
(lambda ()
|
||||
(abort-to-prompt tag)
|
||||
(fluid-ref fluid))))
|
||||
(lambda (k) k))))
|
||||
(fluid-set! fluid #t)
|
||||
(eqv? (k) #f))))
|
||||
|
||||
(pass-if "dynstate captured (3)"
|
||||
(let ((fluid (make-fluid #f))
|
||||
(state (current-dynamic-state))
|
||||
(tag (make-prompt-tag "hey")))
|
||||
(let ((k (call-with-prompt tag
|
||||
(lambda ()
|
||||
(with-dynamic-state
|
||||
state
|
||||
(lambda ()
|
||||
(fluid-set! fluid #t)
|
||||
(abort-to-prompt tag)
|
||||
(fluid-ref fluid))))
|
||||
(lambda (k) k))))
|
||||
(and (eqv? (fluid-ref fluid) #f)
|
||||
(eqv? (k) #t))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue