continuations are vm procedures

* libguile/vm-i-system.c (continuation-call): New op, like subr-call or
  foreign-call, but for continuations.

* libguile/continuations.h: Add scm_i_continuation_call internal
  declaration.
  (SCM_CONTINUATIONP): Reimplement in terms of
  SCM_PROGRAM_IS_CONTINUATION.
  (scm_tc16_continuation, SCM_CONTREGS, SCM_CONTINUATION_LENGTH)
  (SCM_SET_CONTINUATION_LENGTH, SCM_JMPBUF, SCM_DYNENV, SCM_THROW_VALUE)
  (SCM_CONTINUATION_ROOT, SCM_DFRAME): Remove these from the exposed
  API.
  (scm_i_continuation_to_frame): New internal declaration.
* libguile/continuations.c
* libguile/continuations.c: Add trickery like in foreign.c, smob.c, and
  gsubr.c, so that we can make procedural trampolines for continuations.
  (scm_i_continuation_to_frame): New internal function, from stacks.c.

* libguile/programs.h (SCM_F_PROGRAM_IS_CONTINUATION)
  (SCM_PROGRAM_IS_CONTINUATION): Add a flag for programs that are
  continuations. Probably should add flags for the other trampoline
  types too.
* libguile/programs.c (scm_i_program_print): Print continuations as
  before.

* libguile/stacks.c (scm_stack_id, scm_make_stack): Use
  scm_i_continuation_to_frame in the continuation case.

libguile/continuations.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -37,16 +37,117 @@
 #include "libguile/values.h"
 #include "libguile/eval.h"
 #include "libguile/vm.h"
+#include "libguile/instructions.h"
 
 #include "libguile/validate.h"
 #include "libguile/continuations.h"
 
 
 
-/* {Continuations}
+static scm_t_bits tc16_continuation;
+#define SCM_CONTREGSP(x)	SCM_TYP16_PREDICATE (tc16_continuation, x)
+
+#define SCM_CONTREGS(x)		((scm_t_contregs *) SCM_SMOB_DATA_1 (x))
+
+#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
+#define SCM_SET_CONTINUATION_LENGTH(x, n)\
+   (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)
+
+
+
+/* scm_make_continuation will return a procedure whose objcode contains an
+   instruction to reinstate the continuation. Here, as in gsubr.c and smob.c, we
+   define the form of that trampoline function.
  */
 
-scm_t_bits scm_tc16_continuation;
+#ifdef WORDS_BIGENDIAN
+#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 27
+#define META_HEADER    0, 0, 0, 19, 0, 0, 0, 0
+#else
+#define OBJCODE_HEADER 8, 0, 0, 0, 27, 0, 0, 0
+#define META_HEADER    19, 0, 0, 0, 0, 0, 0, 0
+#endif
+
+#define ROUND_UP(len,align) (((len-1)|(align-1))+1)
+#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
+
+#ifdef SCM_ALIGNED
+#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
+static const type sym[]
+#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
+static SCM_ALIGNED (alignment) const type sym[]
+#else
+#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
+static type *sym
+#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)                  \
+SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
+               sym = ALIGN_PTR (type, sym, alignment);                  \
+               memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
+static type *sym = NULL;                                                \
+static const type sym##__unaligned[]
+#endif
+
+#define STATIC_OBJCODE_TAG                                      \
+  SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+#define SCM_STATIC_OBJCODE(sym)                                         \
+  SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode);      \
+  SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = {            \
+    { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) },                 \
+    { SCM_BOOL_F, SCM_PACK (0) }                                        \
+  };                                                                    \
+  static const SCM sym = SCM_PACK (sym##__cells);                       \
+  SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
+
+  
+SCM_STATIC_OBJCODE (cont_objcode) = {
+  /* This code is the same as in gsubr.c, except we use smob_call instead of
+     struct_call. */
+  OBJCODE_HEADER,
+  /* leave args on the stack */
+  /* 0 */ scm_op_object_ref, 0, /* push scm_t_contregs smob */
+  /* 2 */ scm_op_continuation_call, /* and longjmp (whee) */
+  /* 3 */ scm_op_nop, /* pad to 8 bytes */
+  /* 4 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,
+  /* 8 */
+
+  /* We could put some meta-info to say that this proc is a continuation. Not sure
+     how to do that, though. */
+  META_HEADER,
+  /* 0 */ scm_op_make_eol, /* bindings */
+  /* 1 */ scm_op_make_eol, /* sources */
+  /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 3, /* arity: from ip 0 to ip 3 */
+  /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
+  /* 7 */ scm_op_make_int8_0, /* 0 optionals */
+  /* 8 */ scm_op_make_true, /* and a rest arg */
+  /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
+  /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */
+  /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */
+  /* 18 */ scm_op_return /* and return */
+  /* 19 */
+};
+
+
+static SCM
+make_continuation_trampoline (SCM contregs)
+{
+  SCM ret = scm_make_program (cont_objcode,
+                              scm_c_make_vector (1, contregs),
+                              SCM_BOOL_F);
+  SCM_SET_CELL_WORD_0 (ret,
+                       SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_CONTINUATION);
+
+  return ret;
+}
+  
+
+/* {Continuations}
+ */
 
 
 static int
@@ -92,7 +193,7 @@ scm_make_continuation (int *first)
   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
   continuation->vm_conts = scm_vm_capture_continuations ();
 
-  SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
+  SCM_NEWSMOB (cont, tc16_continuation, continuation);
 
   *first = !SCM_I_SETJMP (continuation->jmpbuf);
   if (*first)
@@ -110,7 +211,7 @@ scm_make_continuation (int *first)
               (void *) thread->register_backing_store_base, 
               continuation->backing_store_size);
 #endif /* __ia64__ */
-      return cont;
+      return make_continuation_trampoline (cont);
     }
   else
     {
@@ -121,6 +222,34 @@ scm_make_continuation (int *first)
 }
 #undef FUNC_NAME
 
+SCM
+scm_i_continuation_to_frame (SCM continuation)
+{
+  SCM contregs;
+  scm_t_contregs *cont;
+
+  contregs = scm_c_vector_ref (scm_program_objects (continuation), 0);
+  cont = SCM_CONTREGS (contregs);
+
+  if (!scm_is_null (cont->vm_conts))
+    {
+      SCM vm_cont;
+      struct scm_vm_cont *data;
+      vm_cont = scm_cdr (scm_car (cont->vm_conts));
+      data = SCM_VM_CONT_DATA (vm_cont);
+      return scm_c_make_frame (vm_cont,
+                               data->fp + data->reloc,
+                               data->sp + data->reloc,
+                               data->ip,
+                               data->reloc);
+    }
+  else
+    return SCM_BOOL_F;
+}
+
+
+/* {Apply}
+ */
 
 /* Invoking a continuation proceeds as follows:
  *
@@ -242,24 +371,25 @@ scm_dynthrow (SCM cont, SCM val)
 }
 
 
-static SCM
+void
-continuation_apply (SCM cont, SCM args)
+scm_i_continuation_call (SCM cont, size_t n, SCM *argv)
-#define FUNC_NAME "continuation_apply"
 {
   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
-      SCM_MISC_ERROR 
+      ("%continuation-call", 
-	("invoking continuation would cross continuation barrier: ~A",
+       "invoking continuation would cross continuation barrier: ~A",
-	 scm_list_1 (cont));
+       scm_list_1 (cont));
-    }
   
   scm_dynthrow (cont, scm_values (args));
-  return SCM_UNSPECIFIED; /* not reached */
 }
-#undef FUNC_NAME
 
 SCM
 scm_i_with_continuation_barrier (scm_t_catch_body body,
@@ -374,9 +504,8 @@ SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0,
 void
 scm_init_continuations ()
 {
-  scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
+  tc16_continuation = scm_make_smob_type ("continuation", 0);
-  scm_set_smob_print (scm_tc16_continuation, continuation_print);
+  scm_set_smob_print (tc16_continuation, continuation_print);
-  scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
 #include "libguile/continuations.x"
 }
 

libguile/continuations.h

@@ -3,7 +3,7 @@
 #ifndef SCM_CONTINUATIONS_H
 #define SCM_CONTINUATIONS_H
 
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -31,6 +31,9 @@
 #endif /* __ia64__ */
 
 
+#define SCM_CONTINUATIONP(x) \
+  (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_CONTINUATION (x))
+
 /* a continuation SCM is a non-immediate pointing to a heap cell with:
    word 0: bits 0-15: smob type tag: scm_tc16_continuation.
            bits 16-31: unused.
@@ -39,8 +42,6 @@
 	   in the num_stack_items field of the structure.
 */
 
-SCM_API scm_t_bits scm_tc16_continuation;
-
 typedef struct 
 {
   SCM throw_value;
@@ -67,22 +68,12 @@ typedef struct
   SCM_STACKITEM stack[1];    /* copied stack of size num_stack_items.  */ 
 } scm_t_contregs;
 
-#define SCM_CONTINUATIONP(x)	SCM_TYP16_PREDICATE (scm_tc16_continuation, x)
-
-#define SCM_CONTREGS(x)		((scm_t_contregs *) SCM_SMOB_DATA_1 (x))
-
-#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
-#define SCM_SET_CONTINUATION_LENGTH(x, n)\
-   (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)
 
 
 
 SCM_API SCM scm_make_continuation (int *first);
+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_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
 SCM_API SCM scm_with_continuation_barrier (SCM proc);

libguile/programs.c

@@ -79,7 +79,14 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
       (scm_c_resolve_module ("system vm program"),
        scm_from_locale_symbol ("write-program"));
   
-  if (scm_is_false (write_program) || print_error)
+  if (SCM_PROGRAM_IS_CONTINUATION (program))
+    {
+      /* twingliness */
+      scm_puts ("#<continuation ", port);
+      scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
+      scm_putc ('>', port);
+    }
+  else if (scm_is_false (write_program) || print_error)
     {
       scm_puts ("#<program ", port);
       scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);

libguile/programs.h

@@ -27,8 +27,9 @@
  */
 
 #define SCM_F_PROGRAM_IS_BOOT 0x100
-#define SCM_F_PROGRAM_IS_PRIMITIVE 0x100
+#define SCM_F_PROGRAM_IS_PRIMITIVE 0x200
-#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x200
+#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x400
+#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
 
 #define SCM_PROGRAM_P(x)	(!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
 #define SCM_PROGRAM_OBJCODE(x)	(SCM_CELL_OBJECT_1 (x))
@@ -42,6 +43,7 @@
 #define SCM_PROGRAM_IS_BOOT(x)	(SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
 #define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE)
 #define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
+#define SCM_PROGRAM_IS_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_CONTINUATION)
 
 SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
 

libguile/stacks.c

@@ -1,5 +1,5 @@
 /* A stack holds a frame chain
- * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010 Free Software Foundation
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -209,21 +209,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   else if (SCM_VM_FRAME_P (obj))
     frame = obj;
   else if (SCM_CONTINUATIONP (obj))
-    {
+    frame = scm_i_continuation_to_frame (obj);
-      scm_t_contregs *cont = SCM_CONTREGS (obj);
-      if (!scm_is_null (cont->vm_conts))
-        { SCM vm_cont;
-          struct scm_vm_cont *data;
-          vm_cont = scm_cdr (scm_car (cont->vm_conts));
-          data = SCM_VM_CONT_DATA (vm_cont);
-          frame = scm_c_make_frame (vm_cont,
-                                    data->fp + data->reloc,
-                                    data->sp + data->reloc,
-                                    data->ip,
-                                    data->reloc);
-        } else 
-        frame = SCM_BOOL_F;
-    }
   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
@@ -301,21 +287,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
   else if (SCM_VM_FRAME_P (stack))
     frame = stack;
   else if (SCM_CONTINUATIONP (stack))
-    {
+    frame = scm_i_continuation_to_frame (stack);
-      scm_t_contregs *cont = SCM_CONTREGS (stack);
-      if (!scm_is_null (cont->vm_conts))
-        { SCM vm_cont;
-          struct scm_vm_cont *data;
-          vm_cont = scm_cdr (scm_car (cont->vm_conts));
-          data = SCM_VM_CONT_DATA (vm_cont);
-          frame = scm_c_make_frame (vm_cont,
-                                    data->fp + data->reloc,
-                                    data->sp + data->reloc,
-                                    data->ip,
-                                    data->reloc);
-        } else 
-        frame = SCM_BOOL_F;
-    }
   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);

libguile/vm-i-system.c

@@ -978,6 +978,15 @@ VM_DEFINE_INSTRUCTION (58, foreign_call, "foreign-call", 1, -1, -1)
     }
 }
 
+VM_DEFINE_INSTRUCTION (89, continuation_call, "continuation-call", 0, -1, 0)
+{
+  SCM contregs;
+  POP (contregs);
+  scm_i_continuation_call (contregs, sp - (fp - 1), fp);
+  /* no NEXT */
+  abort ();
+}
+
 VM_DEFINE_INSTRUCTION (59, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
 {
   SCM x;