precise stack marking, fix some missed references, still imperfect

* libguile/vm-engine.h (CHECK_STACK_LEAK, NULLSTACK): Add a new mode,
  VM_ENABLE_STACK_NULLING, that tries to ensure that all stack data past
  the top of the stack is NULL. This helps to verify the VM's
  consistency. If VM_ENABLE_STACK_NULLING is not defined, there is no
  overhead.
  (DROP, DROPN): Hook into NULLSTACK.
  (POP_LIST): Hoo, fix a good bug: if CONS triggered a GC, the elements
  of the list that had not yet been consed would not be marked, because
  the sp was already below them.
  (NEXT): Hook into CHECK_STACK_LEAK.
  (INIT_ARGS): Add a note that consing the rest arg can cause GC.
  (NEW_FRAME): Cons up the external data after initializing the frame, so
  that if GC is triggered, the precise marker sees a well-formed frame.

* libguile/vm-i-loader.c (load-program): In the four-integers case, use
  the POP macro so that we can hook into NULLSTACK (if necessary).

* libguile/vm-i-scheme.c (ARGS2, ARGS3): Hook into NULLSTACK.

* libguile/vm-i-system.c (halt): Null the nvalues. Rework some asserts
  into using ASSERT, and null the stack when we free the frame.
  (variable-set): Use DROPN instead of sp -= 2.
  (BR): Hook into NULLSTACK.
  (goto/args): Hook into NULLSTACK. In the non-self case, delay updating
  the frame until after INIT_ARGS so that GC sees a well-formed frame.
  Delay consing the externals until after the frame is set up, as in
  NEW_FRAME.
  (call/cc): Add some asserts.
  (return): Rework some asserts into ASSERT, and hook into NULLSTACK.
  (return/values): Hook into NULLSTACK, and use ASSERT.
  (return/values*) Use ASSERT.

* libguile/vm.c (VM_ENABLE_ASSERTIONS, VM_ENABLE_STACK_NULLING): These
  are the variables that control assertions and nulling. Perhaps we can
  do these per-engine when we start compiling the debug engine separate
  from a speedy engine.
  (vm_mark_stack): Add a precise stack marker. Yay!
  (vm_cont_mark): Mark the continuation stack precisely.
  (capture_vm_cont): Record the difference from the vp's stack_base too,
  so that we can translate the dynamic links when marking the
  continuation stack. Memset the stack to NULL if we are doing nulling.
  (reinstate_vm_cont): If we are nulling, null out the relevant part
  of the stack.
  (vm_reset_stack): When resetting sp due to a nonlocal exit, null out
  the stack too.
  (vm_mark): If we are nulling, assert that there are no extra values on
  the stack. Mark the stack precisely.

diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index a7e162d..2c15b9d 100644 (file)
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -127,9 +127,7 @@
  * Cache/Sync
  */
 
-#define ENABLE_ASSERTIONS
-
-#ifdef ENABLE_ASSERTIONS
+#ifdef VM_ENABLE_ASSERTIONS
 # define ASSERT(condition) if (SCM_UNLIKELY (!(condition))) abort()
 #else
 # define ASSERT(condition)
@@ -151,7 +149,7 @@
   vp->fp = fp;                                 \
 }
 
-#ifdef IP_PARANOIA
+#ifdef VM_ENABLE_PARANOID_ASSERTIONS
 #define CHECK_IP() \
   do { if (ip < bp->base || ip - bp->base > bp->size) abort (); } while (0)
 #else
@@ -245,6 +243,16 @@
  * Stack operation
  */
 
+#ifdef VM_ENABLE_STACK_NULLING
+# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
+# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
+# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
+#else
+# define CHECK_STACK_LEAKN(_n)
+# define CHECK_STACK_LEAK()
+# define NULLSTACK(_n)
+#endif
+
 #define CHECK_OVERFLOW()                       \
   if (sp > stack_limit)                                \
     goto vm_error_stack_overflow
@@ -254,8 +262,8 @@
     goto vm_error_stack_underflow;
 
 #define PUSH(x)        do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
-#define DROP() do { sp--; CHECK_UNDERFLOW (); } while (0)
-#define DROPN(_n)      do { sp -= (_n); CHECK_UNDERFLOW (); } while (0)
+#define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
+#define DROPN(_n)      do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
 #define POP(x) do { x = *sp; DROP (); } while (0)
 
 /* A fast CONS.  This has to be fast since its used, for instance, by
@@ -275,10 +283,12 @@
 do                                             \
 {                                              \
   int i;                                       \
-  SCM l = SCM_EOL;                             \
-  sp -= n;                                     \
-  for (i = n; i; i--)                          \
-    CONS (l, sp[i], l);                                \
+  SCM l = SCM_EOL, x;                          \
+  for (i = n; i; i--)                           \
+    {                                           \
+      POP (x);                                  \
+      CONS (l, x, l);                           \
+    }                                           \
   PUSH (l);                                    \
 } while (0)
 
@@ -404,6 +414,7 @@ do {                                                \
 {                                              \
   CLOCK (1);                                   \
   NEXT_HOOK ();                                        \
+  CHECK_STACK_LEAK ();                          \
   NEXT_JUMP ();                                        \
 }
 
@@ -419,6 +430,8 @@ do {                                                \
       int n = nargs - (bp->nargs - 1);         \
       if (n < 0)                               \
        goto vm_error_wrong_num_args;           \
+      /* NB, can cause GC while setting up the  \
+         stack frame */                         \
       POP_LIST (n);                            \
     }                                          \
   else                                         \
@@ -453,17 +466,21 @@ do {                                              \
   for (i=bp->nlocs; i; i--)                     \
     data[-i] = SCM_UNDEFINED;                   \
                                                \
-  /* Create external variables */              \
-  external = bp->external;                     \
-  for (i = 0; i < bp->nexts; i++)              \
-    CONS (external, SCM_UNDEFINED, external);  \
-                                               \
   /* Set frame data */                         \
   data[4] = (SCM)ra;                            \
   data[3] = 0x0;                                \
   data[2] = (SCM)dl;                            \
   data[1] = SCM_BOOL_F;                                \
-  data[0] = external;                          \
+                                                \
+  /* Postpone initializing external vars,       \
+     because if the CONS causes a GC, we        \
+     want the stack marker to see the data      \
+     array formatted as expected. */            \
+  data[0] = SCM_UNDEFINED;                      \
+  external = bp->external;                      \
+  for (i = 0; i < bp->nexts; i++)               \
+    CONS (external, SCM_UNDEFINED, external);   \
+  data[0] = external;                           \
 }
 
 #define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]

diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 72436f0..778163f 100644 (file)
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -152,11 +152,10 @@ VM_DEFINE_LOADER (load_program, "load-program")
     {
       /* Other cases */
       /* x is #f, and already popped off */
-      p->nargs = SCM_I_INUM (sp[-3]);
-      p->nrest = SCM_I_INUM (sp[-2]);
-      p->nlocs = SCM_I_INUM (sp[-1]);
-      p->nexts = SCM_I_INUM (sp[0]);
-      sp -= 4;
+      POP (x); p->nexts = scm_to_unsigned_integer (x, 0, 255);
+      POP (x); p->nlocs = scm_to_unsigned_integer (x, 0, 255);
+      POP (x); p->nrest = scm_to_unsigned_integer (x, 0, 1);
+      POP (x); p->nargs = scm_to_unsigned_integer (x, 0, 255);
     }
 
   PUSH (prog);

diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 912c91b..ee724d6 100644 (file)
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -47,8 +47,8 @@
  */
 
 #define ARGS1(a1)      SCM a1 = sp[0];
-#define ARGS2(a1,a2)   SCM a1 = sp[-1], a2 = sp[0]; sp--;
-#define ARGS3(a1,a2,a3)        SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2;
+#define ARGS2(a1,a2)   SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1);
+#define ARGS3(a1,a2,a3)        SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2);
 
 #define RETURN(x)      do { *sp = x; NEXT; } while (0)
 

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 9a0e028..e336e42 100644 (file)
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -58,6 +58,7 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
   vp->time += scm_c_get_internal_run_time () - start_time;
   HALT_HOOK ();
   nvalues = SCM_I_INUM (*sp--);
+  NULLSTACK (1);
   if (nvalues == 1)
     POP (ret);
   else
@@ -69,17 +70,14 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
     }
     
   {
-#ifdef THE_GOVERNMENT_IS_AFTER_ME
-    if (sp != stack_base)
-      abort ();
-    if (stack_base != SCM_FRAME_UPPER_ADDRESS (fp) - 1)
-      abort ();
-#endif
+    ASSERT (sp == stack_base);
+    ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
 
     /* Restore registers */
     sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
     ip = NULL;
     fp = SCM_FRAME_DYNAMIC_LINK (fp);
+    NULLSTACK (stack_base - sp);
   }
   SYNC_ALL ();
   scm_dynwind_end ();
@@ -366,7 +364,7 @@ VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
 VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
 {
   VARIABLE_SET (sp[0], sp[-1]);
-  sp -= 2;
+  DROPN (2);
   NEXT;
 }
 
@@ -435,6 +433,7 @@ VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
   FETCH_OFFSET (offset);                        \
   if (p)                                       \
     ip += offset;                              \
+  NULLSTACK (1);                               \
   DROP ();                                     \
   NEXT;                                                \
 }
@@ -621,6 +620,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
 
       /* Drop the first argument and the program itself.  */
       sp -= 2;
+      NULLSTACK (bp->nargs + 1)
 
       /* Call itself */
       ip = bp->base;
@@ -636,6 +636,9 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
       SCM *data, *tail_args, *dl;
       int i;
       scm_byte_t *ra, *mvra;
+#ifdef VM_ENABLE_STACK_NULLING
+      SCM *old_sp;
+#endif
 
       EXIT_HOOK ();
 
@@ -646,11 +649,19 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
       dl = SCM_FRAME_DYNAMIC_LINK (fp);
 
       /* switch programs */
-      fp[-1] = program = x;
+      program = x;
       CACHE_PROGRAM ();
       INIT_ARGS ();
+      /* delay updating the frame so that if INIT_ARGS has to cons up a rest
+         arg, going into GC, the stack still makes sense */
+      fp[-1] = program;
       nargs = bp->nargs;
 
+#ifdef VM_ENABLE_STACK_NULLING
+      old_sp = sp;
+      CHECK_STACK_LEAK ();
+#endif
+
       /* new registers -- logically this would be better later, but let's make
          sure we have space for the locals now */
       data = SCM_FRAME_DATA_ADDRESS (fp);
@@ -663,21 +674,26 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
       for (i = 0; i < nargs; i++)
         fp[i] = tail_args[i];
 
+      NULLSTACK (old_sp - sp);
+
       /* init locals */
       for (i = bp->nlocs; i; i--)
         data[-i] = SCM_UNDEFINED;
       
-      /* and the external variables */
-      external = bp->external;
-      for (i = 0; i < bp->nexts; i++)
-        CONS (external, SCM_UNDEFINED, external);
-
       /* Set frame data */
       data[4] = (SCM)ra;
       data[3] = (SCM)mvra;
       data[2] = (SCM)dl;
       data[1] = SCM_BOOL_F;
+
+      /* Postpone initializing external vars, because if the CONS causes a GC,
+         we want the stack marker to see the data array formatted as expected. */
+      data[0] = SCM_UNDEFINED;
+      external = bp->external;
+      for (i = 0; i < bp->nexts; i++)
+        CONS (external, SCM_UNDEFINED, external);
       data[0] = external;
+
       ENTER_HOOK ();
       APPLY_HOOK ();
       NEXT;
@@ -887,6 +903,9 @@ VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 0, 1, 1)
       nargs = 1;
       goto vm_call;
     }
+  ASSERT (sp == vp->sp);
+  ASSERT (fp == vp->fp);
+  ASSERT (ip == vp->ip);
   else if (SCM_VALUESP (cont))
     {
       /* multiple values returned to continuation */
@@ -946,18 +965,20 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
     data = SCM_FRAME_DATA_ADDRESS (fp);
 
     POP (ret);
-#ifdef THE_GOVERNMENT_IS_AFTER_ME
-    if (sp != stack_base)
-      abort ();
-    if (stack_base != data + 4)
-      abort ();
-#endif
+    ASSERT (sp == stack_base);
+    ASSERT (stack_base == data + 4);
 
     /* Restore registers */
     sp = SCM_FRAME_LOWER_ADDRESS (fp);
     ip = SCM_FRAME_BYTE_CAST (data[4]);
     fp = SCM_FRAME_STACK_CAST (data[2]);
-    stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+    {
+#ifdef VM_ENABLE_STACK_NULLING
+      int nullcount = stack_base - sp;
+#endif
+      stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+      NULLSTACK (nullcount);
+    }
 
     /* Set return value (sp is already pushed) */
     *sp = ret;
@@ -983,10 +1004,7 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
   RETURN_HOOK ();
 
   data = SCM_FRAME_DATA_ADDRESS (fp);
-#ifdef THE_GOVERNMENT_IS_AFTER_ME
-  if (stack_base != data + 4)
-    abort ();
-#endif
+  ASSERT (stack_base == data + 4);
 
   /* data[3] is the mv return address */
   if (nvalues != 1 && data[3]) 
@@ -1003,6 +1021,7 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
       *++sp = SCM_I_MAKINUM (nvalues);
              
       /* Finally set new stack_base */
+      NULLSTACK (stack_base - sp + nvalues + 1);
       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
     }
   else if (nvalues >= 1)
@@ -1020,6 +1039,7 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
       *++sp = stack_base[1];
              
       /* Finally set new stack_base */
+      NULLSTACK (stack_base - sp);
       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
     }
   else
@@ -1038,10 +1058,7 @@ VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
   SCM l;
 
   nvalues = FETCH ();
-#ifdef THE_GOVERNMENT_IS_AFTER_ME
-  if (nvalues < 1)
-    abort ();
-#endif
+  ASSERT (nvalues >= 1);
     
   nvalues--;
   POP (l);

diff --git a/libguile/vm.c b/libguile/vm.c
index b93d712..6606335 100644 (file)
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -58,6 +58,20 @@
   scm_newline (scm_current_error_port ());      \
 }
 
+/* The VM has a number of internal assertions that shouldn't normally be
+   necessary, but might be if you think you found a bug in the VM. */
+#define VM_ENABLE_ASSERTIONS
+
+/* We can add a mode that ensures that all stack items above the stack pointer
+   are NULL. This is useful for checking the internal consistency of the VM's
+   assumptions and its operators, but isn't necessary for normal operation. It
+   will ensure that assertions are enabled. */
+#define VM_ENABLE_STACK_NULLING
+
+#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
+#define VM_ENABLE_ASSERTIONS
+#endif
+
 \f
 /*
  * VM Continuation
@@ -71,23 +85,53 @@ struct scm_vm_cont {
   scm_t_ptrdiff fp;
   scm_t_ptrdiff stack_size;
   SCM *stack_base;
+  scm_t_ptrdiff reloc;
 };
 
 
 #define SCM_VM_CONT_P(OBJ)     SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
 #define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
 
+static void
+vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
+{
+  SCM *sp, *upper, *lower;
+  sp = base + size - 1;
+
+  while (sp > base && fp) 
+    {
+      upper = SCM_FRAME_UPPER_ADDRESS (fp);
+      lower = SCM_FRAME_LOWER_ADDRESS (fp);
+
+      for (; sp >= upper; sp--)
+        if (SCM_NIMP (*sp)) 
+          {
+            if (scm_in_heap_p (*sp))
+              scm_gc_mark (*sp);
+            else
+              fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp);
+          }
+      
+
+      /* skip ra, mvra */
+      sp -= 2;
+
+      /* update fp from the dynamic link */
+      fp = (SCM*)*sp-- + reloc;
+
+      /* mark from the hl down to the lower address */
+      for (; sp >= lower; sp--)
+        if (*sp && SCM_NIMP (*sp))
+          scm_gc_mark (*sp);
+    }
+}
+
 static SCM
 vm_cont_mark (SCM obj)
 {
-  size_t size;
-  SCM *stack;
-
-  stack = SCM_VM_CONT_DATA (obj)->stack_base;
-  size = SCM_VM_CONT_DATA (obj)->stack_size;
+  struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
 
-  /* we could be smarter about this. */
-  scm_mark_locations ((SCM_STACKITEM *) stack, size);
+  vm_mark_stack (p->stack_base, p->stack_size, p->stack_base + p->fp, p->reloc);
 
   return SCM_BOOL_F;
 }
@@ -110,10 +154,14 @@ capture_vm_cont (struct scm_vm *vp)
   p->stack_size = vp->sp - vp->stack_base + 1;
   p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
                                 "capture_vm_cont");
+#ifdef VM_ENABLE_STACK_NULLING
+  memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
+#endif
   p->ip = vp->ip;
   p->sp = vp->sp - vp->stack_base;
   p->fp = vp->fp - vp->stack_base;
   memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
+  p->reloc = p->stack_base - vp->stack_base;
   SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
 }
 
@@ -126,6 +174,13 @@ reinstate_vm_cont (struct scm_vm *vp, SCM cont)
       /* puts ("FIXME: Need to expand"); */
       abort ();
     }
+#ifdef VM_ENABLE_STACK_NULLING
+  {
+    scm_t_ptrdiff nzero = (vp->sp - vp->stack_base) - p->sp;
+    if (nzero > 0)
+      memset (vp->stack_base + p->stack_size, 0, nzero);
+  }
+#endif
   vp->ip = p->ip;
   vp->sp = vp->stack_base + p->sp;
   vp->fp = vp->stack_base + p->fp;
@@ -173,6 +228,9 @@ vm_reset_stack (void *data)
   w->vp->sp = w->sp;
   w->vp->fp = w->fp;
   w->vp->this_frame = w->this_frame;
+#ifdef VM_ENABLE_STACK_NULLING
+  memset (w->vp->sp + 1, 0, w->vp->stack_size - (w->vp->sp + 1 - w->vp->stack_base));
+#endif
 }
 
 \f
@@ -329,9 +387,14 @@ vm_mark (SCM obj)
   int i;
   struct scm_vm *vp = SCM_VM_DATA (obj);
 
-  /* mark the stack conservatively */
-  scm_mark_locations ((SCM_STACKITEM *) vp->stack_base,
-                      sizeof (SCM)*(vp->sp + 1 - vp->stack_base));
+#ifdef VM_ENABLE_STACK_NULLING
+  if (vp->sp >= vp->stack_base)
+    if (!vp->sp[0] || vp->sp[1])
+      abort ();
+#endif
+
+  /* mark the stack, precisely */
+  vm_mark_stack (vp->stack_base, vp->sp + 1 - vp->stack_base, vp->fp, 0);
 
   /* mark other objects  */
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)