From: Andy Wingo <wingo@pobox.com>
Date: Sat, 30 Jan 2010 14:45:37 +0000 (+0100)
Subject: initial VM support for delimited continuations and dynamic-wind
X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/4f66bcdeff1f5e3d1dd44d745188b91942b04d33

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

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
@@ -170,6 +170,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
  */