[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: with-dynamic-state compiler and VM support
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/02: with-dynamic-state compiler and VM support |
|
Date: |
Mon, 5 Dec 2016 21:57:48 +0000 (UTC) |
wingo pushed a commit to branch master
in repository guile.
commit 7184c176b40db274a92ae14eed1f7d71a0c26e8b
Author: Andy Wingo <address@hidden>
Date: Mon Dec 5 22:48:49 2016 +0100
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.
---
doc/ref/vm.texi | 23 +++++++++
libguile/dynstack.c | 51 ++++++++++++++++++++
libguile/dynstack.h | 5 ++
libguile/memoize.c | 32 +++++++++++++
libguile/vm-engine.c | 31 +++++++++++-
module/ice-9/boot-9.scm | 9 ++++
module/language/cps/compile-bytecode.scm | 4 ++
module/language/cps/effects-analysis.scm | 4 +-
module/language/cps/types.scm | 4 +-
module/language/tree-il/effects.scm | 8 ++++
module/language/tree-il/peval.scm | 13 +++++
module/language/tree-il/primitives.scm | 2 +-
module/system/vm/assembler.scm | 2 +
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 60bce9e..1abbbce 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
address@hidden 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}.
address@hidden deftypefn
+
address@hidden Instruction {} pop-dynamic-state x24:@var{_}
+Restore a saved set of fluid bindings from the dynamic stack.
address@hidden should always be balanced with
address@hidden
address@hidden 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
address@hidden 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.
address@hidden deftypefn
+
address@hidden 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.
address@hidden deftypefn
+
@node Inlined Scheme Instructions
@subsubsection Inlined Scheme Instructions
diff --git a/libguile/dynstack.c b/libguile/dynstack.c
index 7fb8583..ff57c43 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 592e7c8..9d91fb6 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 1267d47..58abeb1 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 1ee2164..4406845 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 7f62097..802ca77 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.
address@hidden 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 7755b1e..db5b8fa 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 38c0bab..9ce6585 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 e8f53bb..c7e4211 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 68bb8a8..a133e32 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 07004a3..993fa0a 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 be613c7..90c1d2d 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 a3d7839..2c6bf81 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 ce7e625..c043d94 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))))))