vm support for display closures

* libguile/vm-i-system.c (box, empty-box): Boxing values and storing
  them in local variables.
  (local-boxed-ref, local-boxed-set): A combination of local-ref then
  variable-ref/set.
  (make-closure2, closure-ref, closure-boxed-ref, closure-boxed-set):
  New ops. The idea is to migrate Guile over to using flat dispay
  closures. See the paper "Three Implementation Models for Scheme" by
  Kent Dybvig for more details; this is the "stack-based" model.

* libguile/vm-engine.c:
* libguile/vm-engine.h: Add the necessary infrastructure to keep track
  of a "closure" variable, like our "externals" in semantics, but
  minimal, flat, and O(1) in implementation.

3 files changed, 130 insertions, 1 deletions

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 90cf697f8..7a98a8a62 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -23,12 +23,14 @@
 #define VM_USE_CLOCK		0	/* Bogoclock */
 #define VM_CHECK_EXTERNAL	1	/* Check external link */
 #define VM_CHECK_OBJECT         1       /* Check object table */
+#define VM_CHECK_CLOSURE        1       /* Check closure vars */
 #define VM_PUSH_DEBUG_FRAMES    0       /* Push frames onto the evaluator debug stack */
 #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
 #define VM_USE_HOOKS		1
 #define VM_USE_CLOCK		1
 #define VM_CHECK_EXTERNAL	1
 #define VM_CHECK_OBJECT         1
+#define VM_CHECK_CLOSURE        1
 #define VM_PUSH_DEBUG_FRAMES    1
 #else
 #error unknown debug engine VM_ENGINE
@@ -47,7 +49,9 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
 
   /* Cache variables */
   struct scm_objcode *bp = NULL;	/* program base pointer */
-  SCM external = SCM_EOL;		/* external environment */
+  SCM external = SCM_EOL;		/* external environment REMOVEME */
+  SCM *closure = NULL;                  /* closure variables */
+  size_t closure_count = 0;             /* length of CLOSURE */
   SCM *objects = NULL;			/* constant objects */
   size_t object_count = 0;              /* length of OBJECTS */
   SCM *stack_base = vp->stack_base;	/* stack base address */
@@ -240,6 +244,13 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
     goto vm_error;
 #endif
 
+#if VM_CHECK_CLOSURE
+  vm_error_closure:
+    err_msg = scm_from_locale_string ("VM: Invalid closure variable access");
+    finish_args = SCM_EOL;
+    goto vm_error;
+#endif
+
   vm_error:
     SYNC_ALL ();
 
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index d6849799c..a2c1effd3 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -117,6 +117,16 @@
   vp->fp = fp;					\
 }
 
+/* FIXME */
+#define ASSERT_VARIABLE(x)                                              \
+  do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); }           \
+  } while (0)
+#define ASSERT_BOUND_VARIABLE(x)                                        \
+  do { ASSERT_VARIABLE (x);                                             \
+    if (SCM_VARIABLE_REF (x) == SCM_UNDEFINED)                          \
+      { SYNC_REGISTER (); abort(); }                                    \
+  } while (0)
+
 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
 #define CHECK_IP() \
   do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
@@ -145,6 +155,19 @@
       object_count = 0;                                                 \
     }                                                                   \
   }                                                                     \
+  {                                                                     \
+    SCM c = SCM_PROGRAM_EXTERNALS (program);                            \
+    if (SCM_I_IS_VECTOR (c))                                            \
+      {                                                                 \
+        closure = SCM_I_VECTOR_WELTS (c);                               \
+        closure_count = SCM_I_VECTOR_LENGTH (c);                        \
+      }                                                                 \
+    else                                                                \
+      {                                                                 \
+        closure = NULL;                                                 \
+        closure_count = 0;                                              \
+      }                                                                 \
+  }                                                                     \
 }
 
 #define SYNC_BEFORE_GC()			\
@@ -178,6 +201,13 @@
 #define CHECK_OBJECT(_num)
 #endif
 
+#if VM_CHECK_CLOSURE
+#define CHECK_CLOSURE(_num) \
+  do { if (SCM_UNLIKELY ((_num) >= closure_count)) goto vm_error_closure; } while (0)
+#else
+#define CHECK_CLOSURE(_num)
+#endif
+
 
 /*
  * Hooks
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index d884557e1..5e850a1a6 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -248,6 +248,8 @@ VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
 #define VARIABLE_SET(v,o)	SCM_VARIABLE_SET (v, o)
 #define VARIABLE_BOUNDP(v)      (VARIABLE_REF (v) != SCM_UNDEFINED)
 
+#define CLOSURE_REF(i)		closure[i]
+
 /* ref */
 
 VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
@@ -1150,6 +1152,92 @@ VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
+{
+  SCM val;
+  POP (val);
+  SYNC_BEFORE_GC ();
+  LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
+  NEXT;
+}
+
+/* for letrec:
+   (let ((a *undef*) (b *undef*) ...)
+     (set! a (lambda () (b ...)))
+     ...)
+ */
+VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
+{
+  SYNC_BEFORE_GC ();
+  LOCAL_SET (FETCH (),
+             scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+{
+  SCM v = LOCAL_REF (FETCH ());
+  ASSERT_BOUND_VARIABLE (v);
+  PUSH (VARIABLE_REF (v));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
+{
+  SCM v, val;
+  v = LOCAL_REF (FETCH ());
+  POP (val);
+  ASSERT_VARIABLE (v);
+  VARIABLE_SET (v, val);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (60, closure_ref, "closure-ref", 1, 0, 1)
+{
+  scm_t_uint8 idx = FETCH ();
+  
+  CHECK_CLOSURE (idx);
+  PUSH (CLOSURE_REF (idx));
+  NEXT;
+}
+
+/* no closure-set -- if a var is assigned, it should be in a box */
+
+VM_DEFINE_INSTRUCTION (61, closure_boxed_ref, "closure-boxed-ref", 1, 0, 1)
+{
+  SCM v;
+  scm_t_uint8 idx = FETCH ();
+  CHECK_CLOSURE (idx);
+  v = CLOSURE_REF (idx);
+  ASSERT_BOUND_VARIABLE (v);
+  PUSH (VARIABLE_REF (v));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (62, closure_boxed_set, "closure-boxed-set", 1, 1, 0)
+{
+  SCM v, val;
+  scm_t_uint8 idx = FETCH ();
+  POP (val);
+  CHECK_CLOSURE (idx);
+  v = CLOSURE_REF (idx);
+  ASSERT_BOUND_VARIABLE (v);
+  VARIABLE_SET (v, val);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (63, make_closure2, "make-closure2", 0, 2, 1)
+{
+  SCM vect;
+  POP (vect);
+  SYNC_BEFORE_GC ();
+  /* fixme underflow */
+  SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
+                SCM_PROGRAM_OBJTABLE (*sp), vect);
+  NEXT;
+}
+
+
 /*
 (defun renumber-ops ()
   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"