summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-01-30 15:45:37 +0100
committerAndy Wingo <wingo@pobox.com>2010-01-31 20:40:21 +0100
commit4f66bcdeff1f5e3d1dd44d745188b91942b04d33 (patch)
tree6c5bc7557ba61cef2d88244ee72a35cff59943a3
parent17d819d4c43701e0e0e92f6c2001343d4730db83 (diff)
downloadguile-4f66bcdeff1f5e3d1dd44d745188b91942b04d33.tar.gz
initial VM support for delimited continuations and dynamic-wind
* libguile/vm-i-system.c (prompt, wind, throw, unwind): New instructions, for implementing dynamic-wind and delimited continuations. * libguile/vm.c: Add some stub support for the new instructions. * libguile/vm-engine.c: Some new error conditions.
-rw-r--r--libguile/vm-engine.c6
-rw-r--r--libguile/vm-i-system.c81
-rw-r--r--libguile/vm.c21
3 files changed, 108 insertions, 0 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index c46834b2e..75dd613ed 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -214,6 +214,12 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* shouldn't get here */
goto vm_error;
+ vm_error_not_a_thunk:
+ SYNC_ALL ();
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "thunk");
+ /* shouldn't get here */
+ goto vm_error;
+
vm_error_no_values:
err_msg = scm_from_locale_string ("Zero values returned to single-valued continuation");
finish_args = SCM_EOL;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 8c280fd28..258aa529e 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1433,6 +1433,87 @@ VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 0, 1, 1)
NEXT;
}
+VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 3, 0)
+{
+ scm_t_int32 offset;
+ scm_t_uint8 inline_handler_p, escape_only_p;
+ SCM k, handler, pre_unwind, jmpbuf;
+
+ inline_handler_p = FETCH ();
+ escape_only_p = FETCH ();
+ FETCH_OFFSET (offset);
+ POP (pre_unwind);
+ POP (handler);
+ POP (k);
+
+ SYNC_REGISTER ();
+ /* Push the prompt onto the dynamic stack. The setjmp itself has to be local
+ to this procedure. */
+ jmpbuf = vm_prepare_prompt_jmpbuf (vm, k, handler, pre_unwind,
+ inline_handler_p, escape_only_p);
+ if (VM_SETJMP (jmpbuf))
+ {
+ /* The prompt exited nonlocally. Cache the regs back from the vp, and go
+ to the handler or post-handler label. (The meaning of the label differs
+ depending on whether the prompt's handler is rendered inline or not.)
+ */
+ CACHE_REGISTER (); /* Really we only need SP. FP and IP should be
+ unmodified. */
+ ip += offset;
+ NEXT;
+ }
+
+ /* Otherwise setjmp returned for the first time, so we go to execute the
+ prompt's body. */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (85, wind, "wind", 0, 2, 0)
+{
+ SCM wind, unwind;
+ POP (unwind);
+ POP (wind);
+ SYNC_REGISTER ();
+ /* Push wind and unwind procedures onto the dynamic stack. Note that neither
+ are actually called; the compiler should emit calls to wind and unwind for
+ the normal dynamic-wind control flow. */
+ if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
+ {
+ finish_args = wind;
+ goto vm_error_not_a_thunk;
+ }
+ if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
+ {
+ finish_args = unwind;
+ goto vm_error_not_a_thunk;
+ }
+ scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (86, throw, "throw", 1, -1, -1)
+{
+ unsigned n = FETCH ();
+ SCM k;
+ SCM args;
+ POP_LIST (n);
+ POP (args);
+ POP (k);
+ SYNC_REGISTER ();
+ vm_throw (vm, k, args);
+ /* vm_throw should not return */
+ abort ();
+}
+
+VM_DEFINE_INSTRUCTION (87, unwind, "unwind", 0, 0, 0)
+{
+ /* A normal exit from the dynamic extent of an expression. Pop the top entry
+ off of the dynamic stack. */
+ scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ NEXT;
+}
+
+
/*
(defun renumber-ops ()
diff --git a/libguile/vm.c b/libguile/vm.c
index afa888e52..4c647b0b8 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -171,6 +171,27 @@ vm_dispatch_hook (SCM vm, int hook_num)
/*
+ * The dynamic stack
+ */
+static SCM
+vm_prepare_prompt_jmpbuf (SCM vm, SCM k, SCM handler, SCM pre_unwind,
+ scm_t_uint8 inline_p, scm_t_uint8 escape_only_p)
+{
+ abort ();
+ return SCM_BOOL_F;
+}
+
+#define VM_SETJMP(jmpbuf) 0
+
+static void vm_throw (SCM vm, SCM k, SCM args) SCM_NORETURN;
+static void
+vm_throw (SCM vm, SCM k, SCM args)
+{
+ abort ();
+}
+
+
+/*
* VM Internal functions
*/