diff options
author | Andy Wingo <wingo@pobox.com> | 2016-12-05 22:48:49 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2016-12-05 22:57:29 +0100 |
commit | 7184c176b40db274a92ae14eed1f7d71a0c26e8b (patch) | |
tree | dd42a2d278fed8aed8af812fdc377599d09e6328 | |
parent | aa84489d18320df086e08554554d6f3b92c45893 (diff) | |
download | guile-7184c176b40db274a92ae14eed1f7d71a0c26e8b.tar.gz |
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.
-rw-r--r-- | doc/ref/vm.texi | 23 | ||||
-rw-r--r-- | libguile/dynstack.c | 51 | ||||
-rw-r--r-- | libguile/dynstack.h | 5 | ||||
-rw-r--r-- | libguile/memoize.c | 32 | ||||
-rw-r--r-- | libguile/vm-engine.c | 31 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 9 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 4 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 4 | ||||
-rw-r--r-- | module/language/cps/types.scm | 4 | ||||
-rw-r--r-- | module/language/tree-il/effects.scm | 8 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 13 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 2 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 2 | ||||
-rw-r--r-- | test-suite/tests/fluids.test | 77 |
14 files changed, 260 insertions, 5 deletions
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 60bce9ed3..1abbbce15 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -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 diff --git a/libguile/dynstack.c b/libguile/dynstack.c index 7fb858391..ff57c430d 100644 --- a/libguile/dynstack.c +++ b/libguile/dynstack.c @@ -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])) + @@ -231,6 +234,22 @@ dynstack_pop (scm_t_dynstack *dynstack, scm_t_bits **words) } 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) { scm_t_bits tag, *words; @@ -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: diff --git a/libguile/dynstack.h b/libguile/dynstack.h index 592e7c819..9d91fb667 100644 --- a/libguile/dynstack.h +++ b/libguile/dynstack.h @@ -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 *, diff --git a/libguile/memoize.c b/libguile/memoize.c index 1267d4771..58abeb110 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -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")); } diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 1ee21642f..44068458e 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -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) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 7f620979d..802ca7735 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -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} diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 7755b1e67..db5b8fa70 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -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)) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 38c0bab7e..9ce65853d 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -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 diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index e8f53bb3f..c7e42117c 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -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))) diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm index 68bb8a8a4..a133e3269 100644 --- a/module/language/tree-il/effects.scm +++ b/module/language/tree-il/effects.scm @@ -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) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 07004a349..993fa0ad6 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -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) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index be613c714..90c1d2d1a 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -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 diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index a3d7839f5..2c6bf816a 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -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! diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test index ce7e62578..c043d94d3 100644 --- a/test-suite/tests/fluids.test +++ b/test-suite/tests/fluids.test @@ -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)))))) |