summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/vm-engine.h49
-rw-r--r--libguile/vm-i-loader.c9
-rw-r--r--libguile/vm-i-scheme.c4
-rw-r--r--libguile/vm-i-system.c73
-rw-r--r--libguile/vm.c83
5 files changed, 157 insertions, 61 deletions
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index a7e162d96..2c15b9d63 100644
--- 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 72436f0d5..778163f0f 100644
--- 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 912c91bf2..ee724d633 100644
--- 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 9a0e028a5..e336e4215 100644
--- 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 b93d7125e..6606335ba 100644
--- 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
+
/*
* 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
}
@@ -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++)