diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/vm-engine.h | 49 | ||||
-rw-r--r-- | libguile/vm-i-loader.c | 9 | ||||
-rw-r--r-- | libguile/vm-i-scheme.c | 4 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 73 | ||||
-rw-r--r-- | libguile/vm.c | 83 |
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++) |