continuations return multiple values on the stack

* libguile/vm.h (struct scm_vm_cont): Instead of saving the "IP", save
  "RA" and "MVRA". That is, save singly-valued and multiply-valued
  return addresses, so that we can return multiple values on the stack.
  (scm_i_vm_reinstate_continuation): Remove.
* libguile/vm.c (vm_capture_continuation): Rename from capture_vm_cont,
  and change the prototype so we can capture the RA and MVRA, and so
  that tail calls to call/cc can capture a continuation without the
  call/cc application frame.
  (vm_return_to_continuation): Rename from reinstate_vm_cont, and take
  arguments to return to the continuation. Handles returning to single
  or multiple-value RA.
  (scm_i_vm_capture_continuation): Change to invoke
  vm_capture_continuation. Kept around for the benefit of make-stack.

* libguile/vm-i-system.c (continuation-call): Handle reinstatement of
  the VM stack, with arguments.
  (call/cc, tail-call/cc): Adapt to new vm_capture_continuation
  prototype. tail-call/cc captures tail continuations.

* libguile/stacks.c (scm_make_stack): Update for scm_vm_cont structure
  change.

* libguile/continuations.h (struct scm_contregs): Remove throw_value
  member, which was used to return a value to a continuation.
  (scm_i_check_continuation): New internal function, checks that a
  continuation may be reinstated.
  (scm_i_reinstate_continuation): Replaces scm_i_continuation_call; just
  reinstates the C stack.
  (scm_i_contregs_vm, scm_i_contregs_vm_cont): New internal accessors.
* libguile/continuations.c (scm_i_make_continuation): Return
  SCM_UNDEFINED if we are returning again.
  (grow_stack, copy_stack_and_call, scm_dynthrow): Remove extra arg, as
  vm opcodes handle value returns.
  (copy_stack): No need to instate VM continuation.
  (scm_i_reinstate_continuation): Adapt.

libguile/continuations.c

@@ -34,7 +34,6 @@
 #include "libguile/smob.h"
 #include "libguile/ports.h"
 #include "libguile/dynwind.h"
-#include "libguile/values.h"
 #include "libguile/eval.h"
 #include "libguile/vm.h"
 #include "libguile/instructions.h"
@@ -54,7 +53,6 @@ static scm_t_bits tc16_continuation;
    (SCM_CONTREGS (x)->num_stack_items = (n))
 #define SCM_JMPBUF(x)		 ((SCM_CONTREGS (x))->jmpbuf)
 #define SCM_DYNENV(x)		 ((SCM_CONTREGS (x))->dynenv)
-#define SCM_THROW_VALUE(x)	 ((SCM_CONTREGS (x))->throw_value)
 #define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)   
 #define SCM_DFRAME(x)		 ((SCM_CONTREGS (x))->dframe)
 
@@ -187,8 +185,8 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
 }
 
 /* this may return more than once: the first time with the escape
-   procedure, then subsequently with the value to be passed to the
+   procedure, then subsequently with SCM_UNDEFINED (the vals already having been
-   continuation.  */
+   placed on the VM stack). */
 #define FUNC_NAME "scm_i_make_continuation"
 SCM 
 scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
@@ -206,7 +204,6 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
 				"continuation");
   continuation->num_stack_items = stack_size;
   continuation->dynenv = scm_i_dynwinds ();
-  continuation->throw_value = SCM_EOL;
   continuation->root = thread->continuation_root;
   src = thread->continuation_base;
 #if ! SCM_STACK_GROWS_UP
@@ -238,11 +235,7 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
       return make_continuation_trampoline (cont);
     }
   else
-    {
+    return SCM_UNDEFINED;
-      SCM ret = continuation->throw_value;
-      continuation->throw_value = SCM_BOOL_F;
-      return ret;
-    }
 }
 #undef FUNC_NAME
 
@@ -272,13 +265,25 @@ scm_i_continuation_to_frame (SCM continuation)
       return scm_c_make_frame (cont->vm_cont,
                                data->fp + data->reloc,
                                data->sp + data->reloc,
-                               data->ip,
+                               data->ra,
                                data->reloc);
     }
   else
     return SCM_BOOL_F;
 }
 
+SCM
+scm_i_contregs_vm (SCM contregs)
+{
+  return SCM_CONTREGS (contregs)->vm;
+}
+
+SCM
+scm_i_contregs_vm_cont (SCM contregs)
+{
+  return SCM_CONTREGS (contregs)->vm_cont;
+}
+
 
 /* {Apply}
  */
@@ -295,7 +300,7 @@ scm_i_continuation_to_frame (SCM continuation)
  * with their correct stack.
  */
 
-static void scm_dynthrow (SCM, SCM);
+static void scm_dynthrow (SCM);
 
 /* Grow the stack by a fixed amount to provide space to copy in the
  * continuation.  Possibly this function has to be called several times
@@ -307,12 +312,12 @@ static void scm_dynthrow (SCM, SCM);
 scm_t_bits scm_i_dummy;
 
 static void 
-grow_stack (SCM cont, SCM val)
+grow_stack (SCM cont)
 {
   scm_t_bits growth[100];
 
   scm_i_dummy = (scm_t_bits) growth;
-  scm_dynthrow (cont, val);
+  scm_dynthrow (cont);
 }
 
 
@@ -332,15 +337,13 @@ copy_stack (void *data)
   copy_stack_data *d = (copy_stack_data *)data;
   memcpy (d->dst, d->continuation->stack,
 	  sizeof (SCM_STACKITEM) * d->continuation->num_stack_items);
-  scm_i_vm_reinstate_continuation (d->continuation->vm,
-                                   d->continuation->vm_cont);
 #ifdef __ia64__
   SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation;
 #endif
 }
 
 static void
-copy_stack_and_call (scm_t_contregs *continuation, SCM val,
+copy_stack_and_call (scm_t_contregs *continuation,
 		     SCM_STACKITEM * dst)
 {
   long delta;
@@ -351,7 +354,6 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
   data.dst = dst;
   scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
 
-  continuation->throw_value = val;
   SCM_I_LONGJMP (continuation->jmpbuf, 1);
 }
 
@@ -377,7 +379,7 @@ scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL)
  * actual copying and continuation calling.
  */
 static void 
-scm_dynthrow (SCM cont, SCM val)
+scm_dynthrow (SCM cont)
 {
   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
   scm_t_contregs *continuation = SCM_CONTREGS (cont);
@@ -392,36 +394,35 @@ scm_dynthrow (SCM cont, SCM val)
 
 #if SCM_STACK_GROWS_UP
   if (dst + continuation->num_stack_items >= &stack_top_element)
-    grow_stack (cont, val);
+    grow_stack (cont);
 #else
   dst -= continuation->num_stack_items;
   if (dst <= &stack_top_element)
-    grow_stack (cont, val);
+    grow_stack (cont);
 #endif /* def SCM_STACK_GROWS_UP */
 
   SCM_FLUSH_REGISTER_WINDOWS;
-  copy_stack_and_call (continuation, val, dst);
+  copy_stack_and_call (continuation, dst);
 }
 
 
 void
-scm_i_continuation_call (SCM cont, size_t n, SCM *argv)
+scm_i_check_continuation (SCM cont)
 {
   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
   scm_t_contregs *continuation = SCM_CONTREGS (cont);
-  SCM args = SCM_EOL;
-  
-  /* FIXME: shuffle args on VM stack instead of heap-allocating */
-  while (n--)
-    args = scm_cons (argv[n], args);
 
   if (continuation->root != thread->continuation_root)
     scm_misc_error
       ("%continuation-call", 
        "invoking continuation would cross continuation barrier: ~A",
        scm_list_1 (cont));
+}
 
-  scm_dynthrow (cont, scm_values (args));
+void
+scm_i_reinstate_continuation (SCM cont)
+{
+  scm_dynthrow (cont);
 }
 
 SCM

libguile/continuations.h

@@ -44,7 +44,6 @@
 
 typedef struct 
 {
-  SCM throw_value;
   scm_i_jmp_buf jmpbuf;
   SCM dynenv;
 #ifdef __ia64__
@@ -73,9 +72,14 @@ typedef struct
 
 
 SCM_INTERNAL SCM scm_i_make_continuation (int *first, SCM vm, SCM vm_cont);
+SCM_INTERNAL void scm_i_check_continuation (SCM cont);
+SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);
+
 SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
+
 SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
-SCM_INTERNAL void scm_i_continuation_call (SCM cont, size_t n, SCM *argv);
+SCM_INTERNAL SCM scm_i_contregs_vm (SCM contregs);
+SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);
 
 SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
 SCM_API SCM scm_with_continuation_barrier (SCM proc);

libguile/stacks.c

@@ -203,7 +203,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
       c = SCM_VM_CONT_DATA (cont);
 
       frame = scm_c_make_frame (cont, c->fp + c->reloc,
-                                c->sp + c->reloc, c->ip,
+                                c->sp + c->reloc, c->ra,
                                 c->reloc);
     }
   else if (SCM_VM_FRAME_P (obj))

libguile/vm-i-system.c

@@ -982,7 +982,13 @@ VM_DEFINE_INSTRUCTION (89, continuation_call, "continuation-call", 0, -1, 0)
 {
   SCM contregs;
   POP (contregs);
-  scm_i_continuation_call (contregs, sp - (fp - 1), fp);
+
+  scm_i_check_continuation (contregs);
+  vm_return_to_continuation (scm_i_contregs_vm (contregs),
+                             scm_i_contregs_vm_cont (contregs),
+                             sp - (fp - 1), fp);
+  scm_i_reinstate_continuation (contregs);
+
   /* no NEXT */
   abort ();
 }
@@ -1090,10 +1096,11 @@ VM_DEFINE_INSTRUCTION (63, tail_apply, "tail-apply", 1, -1, 1)
 VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1)
 {
   int first;
-  SCM proc, cont;
+  SCM proc, vm_cont, cont;
   POP (proc);
   SYNC_ALL ();
-  cont = scm_i_make_continuation (&first, vm, capture_vm_cont (vp));
+  vm_cont = vm_capture_continuation (vp->stack_base, fp, sp, ip, NULL);
+  cont = scm_i_make_continuation (&first, vm, vm_cont);
   if (first) 
     {
       PUSH ((SCM)fp); /* dynamic link */
@@ -1104,22 +1111,14 @@ VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1)
       nargs = 1;
       goto vm_call;
     }
-  ASSERT (sp == vp->sp);
-  ASSERT (fp == vp->fp);
-  else if (SCM_VALUESP (cont))
-    {
-      /* multiple values returned to continuation */
-      SCM values;
-      values = scm_struct_ref (cont, SCM_INUM0);
-      if (scm_is_null (values))
-        goto vm_error_no_values;
-      /* non-tail context does not accept multiple values? */
-      PUSH (SCM_CAR (values));
-      NEXT;
-    }
   else 
     {
-      PUSH (cont);
+      /* otherwise, the vm continuation was reinstated, and
+         scm_i_vm_return_to_continuation pushed on one value. So pull our regs
+         back down from the vp, and march on to the next instruction. */
+      CACHE_REGISTER ();
+      program = SCM_FRAME_PROGRAM (fp);
+      CACHE_PROGRAM ();
       NEXT;
     }
 }
@@ -1127,12 +1126,17 @@ VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1)
 VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc", 0, 1, 1)
 {
   int first;
-  SCM proc, cont;
+  SCM proc, vm_cont, cont;
   POP (proc);
   SYNC_ALL ();
-  cont = scm_i_make_continuation (&first, vm, capture_vm_cont (vp));
+  /* In contrast to call/cc, tail-call/cc captures the continuation without the
-  ASSERT (sp == vp->sp);
+     stack frame. */
-  ASSERT (fp == vp->fp);
+  vm_cont = vm_capture_continuation (vp->stack_base,
+                                     SCM_FRAME_DYNAMIC_LINK (fp),
+                                     SCM_FRAME_LOWER_ADDRESS (fp) - 1,
+                                     SCM_FRAME_RETURN_ADDRESS (fp),
+                                     SCM_FRAME_MV_RETURN_ADDRESS (fp));
+  cont = scm_i_make_continuation (&first, vm, vm_cont);
   if (first) 
     {
       PUSH (proc);
@@ -1140,19 +1144,14 @@ VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc", 0, 1, 1)
       nargs = 1;
       goto vm_tail_call;
     }
-  else if (SCM_VALUESP (cont))
-    {
-      /* multiple values returned to continuation */
-      SCM values;
-      values = scm_struct_ref (cont, SCM_INUM0);
-      nvalues = scm_ilength (values);
-      PUSH_LIST (values, scm_is_null);
-      goto vm_return_values;
-    }
   else
     {
-      PUSH (cont);
+      /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
-      goto vm_return;
+         does a return from the frame, either to the RA or MVRA. */
+      CACHE_REGISTER ();
+      program = SCM_FRAME_PROGRAM (fp);
+      CACHE_PROGRAM ();
+      NEXT;
     }
 }
 

libguile/vm.c

@@ -80,72 +80,105 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
   scm_puts (">", port);
 }
 
+/* In theory, a number of vm instances can be active in the call trace, and we
+   only want to reify the continuations of those in the current continuation
+   root. I don't see a nice way to do this -- ideally it would involve dynwinds,
+   and previous values of the *the-vm* fluid within the current continuation
+   root. But we don't have access to continuation roots in the dynwind stack.
+   So, just punt for now, we just capture the continuation for the current VM.
+
+   While I'm on the topic, ideally we could avoid copying the C stack if the
+   continuation root is inside VM code, and call/cc was invoked within that same
+   call to vm_run; but that's currently not implemented.
+ */
 static SCM
-capture_vm_cont (struct scm_vm *vp)
+vm_capture_continuation (SCM *stack_base,
+                         SCM *fp, SCM *sp, scm_t_uint8 *ra, scm_t_uint8 *mvra)
 {
-  struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+  struct scm_vm_cont *p;
-  p->stack_size = vp->sp - vp->stack_base + 1;
+
+  p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+  p->stack_size = sp - stack_base + 1;
   p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
 				 "capture_vm_cont");
-#ifdef VM_ENABLE_STACK_NULLING
+#if defined(VM_ENABLE_STACK_NULLING) && 0
-  if (vp->sp >= vp->stack_base)
+  /* Tail continuations leave their frame on the stack for subsequent
+     application, but don't capture the frame -- so there are some elements on
+     the stack then, and this check doesn't work, so disable it for now. */
+  if (sp >= vp->stack_base)
     if (!vp->sp[0] || vp->sp[1])
       abort ();
   memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
 #endif
-  p->ip = vp->ip;
+  p->ra = ra;
-  p->sp = vp->sp;
+  p->mvra = mvra;
-  p->fp = vp->fp;
+  p->sp = sp;
-  memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
+  p->fp = fp;
-  p->reloc = p->stack_base - vp->stack_base;
+  memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
+  p->reloc = p->stack_base - stack_base;
   return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
 }
 
 static void
-reinstate_vm_cont (struct scm_vm *vp, SCM cont)
+vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
 {
-  struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont);
+  struct scm_vm *vp;
-  if (vp->stack_size < p->stack_size)
+  struct scm_vm_cont *cp;
+  SCM *argv_copy;
+
+  argv_copy = alloca (n * sizeof(SCM));
+  memcpy (argv_copy, argv, n * sizeof(SCM));
+
+  vp = SCM_VM_DATA (vm);
+  cp = SCM_VM_CONT_DATA (cont);
+
+  if (n == 0 && !cp->mvra)
+    scm_misc_error (NULL, "Too few values returned to continuation",
+                    SCM_EOL);
+
+  if (vp->stack_size < cp->stack_size + n + 1)
     {
       /* puts ("FIXME: Need to expand"); */
       abort ();
     }
 #ifdef VM_ENABLE_STACK_NULLING
   {
-    scm_t_ptrdiff nzero = (vp->sp - p->sp);
+    scm_t_ptrdiff nzero = (vp->sp - cp->sp);
     if (nzero > 0)
-      memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM));
+      memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
     /* actually nzero should always be negative, because vm_reset_stack will
        unwind the stack to some point *below* this continuation */
   }
 #endif
-  vp->ip = p->ip;
+  vp->sp = cp->sp;
-  vp->sp = p->sp;
+  vp->fp = cp->fp;
-  vp->fp = p->fp;
+  memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
-  memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM));
+
+  if (n == 1 || !cp->mvra)
+    {
+      vp->ip = cp->ra;
+      vp->sp++;
+      *vp->sp = argv_copy[0];
+    }
+  else
+    {
+      size_t i;
+      for (i = 0; i < n; i++)
+        {
+          vp->sp++;
+          *vp->sp = argv_copy[i];
+        }
+      vp->sp++;
+      *vp->sp = scm_from_size_t (n);
+      vp->ip = cp->mvra;
+    }
 }
 
-/* In theory, a number of vm instances can be active in the call trace, and we
-   only want to reify the continuations of those in the current continuation
-   root. I don't see a nice way to do this -- ideally it would involve dynwinds,
-   and previous values of the *the-vm* fluid within the current continuation
-   root. But we don't have access to continuation roots in the dynwind stack.
-   So, just punt for now -- take the current value of *the-vm*.
-
-   While I'm on the topic, ideally we could avoid copying the C stack if the
-   continuation root is inside VM code, and call/cc was invoked within that same
-   call to vm_run; but that's currently not implemented.
- */
 SCM
 scm_i_vm_capture_continuation (SCM vm)
 {
-  return capture_vm_cont (SCM_VM_DATA (vm));
+  struct scm_vm *vp = SCM_VM_DATA (vm);
-}
+  return vm_capture_continuation (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL);
-
-void
-scm_i_vm_reinstate_continuation (SCM vm, SCM cont)
-{
-  reinstate_vm_cont (SCM_VM_DATA (vm), cont);
 }
 
 static void

libguile/vm.h

@@ -87,9 +87,9 @@ SCM_API SCM scm_vm_trace_level (SCM vm);
 SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
 
 struct scm_vm_cont {
-  scm_t_uint8 *ip;
   SCM *sp;
   SCM *fp;
+  scm_t_uint8 *ra, *mvra;
   scm_t_ptrdiff stack_size;
   SCM *stack_base;
   scm_t_ptrdiff reloc;
@@ -98,13 +98,11 @@ struct scm_vm_cont {
 #define SCM_VM_CONT_P(OBJ)	(SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) == scm_tc7_vm_cont)
 #define SCM_VM_CONT_DATA(CONT)	((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
 
-SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);
-SCM_INTERNAL void scm_i_vm_reinstate_continuation (SCM vm, SCM cont);
-
 SCM_API SCM scm_load_compiled_with_vm (SCM file);
 
 SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
                                   scm_print_state *pstate);
+SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);
 SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
                                        scm_print_state *pstate);
 SCM_INTERNAL void scm_bootstrap_vm (void);