diff options
Diffstat (limited to 'libguile/vm.c')
| -rw-r--r-- | libguile/vm.c | 394 |
1 files changed, 197 insertions, 197 deletions
diff --git a/libguile/vm.c b/libguile/vm.c index 0e5983575..d5a72727f 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -16,9 +16,6 @@ * 02110-1301 USA */ -/* For mremap(2) on GNU/Linux systems. */ -#define _GNU_SOURCE - #if HAVE_CONFIG_H # include <config.h> #endif @@ -65,7 +62,8 @@ static size_t page_size; necessary, but might be if you think you found a bug in the VM. */ /* #define VM_ENABLE_ASSERTIONS */ -static void vm_expand_stack (struct scm_vm *vp, SCM *new_sp) SCM_NOINLINE; +static void vm_expand_stack (struct scm_vm *vp, + union scm_vm_stack_element *new_sp) SCM_NOINLINE; /* RESTORE is for the case where we know we have done a PUSH of equal or greater stack size in the past. Otherwise PUSH is the thing, which @@ -73,28 +71,29 @@ static void vm_expand_stack (struct scm_vm *vp, SCM *new_sp) SCM_NOINLINE; enum vm_increase_sp_kind { VM_SP_PUSH, VM_SP_RESTORE }; static inline void -vm_increase_sp (struct scm_vm *vp, SCM *new_sp, enum vm_increase_sp_kind kind) +vm_increase_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp, + enum vm_increase_sp_kind kind) { - if (new_sp <= vp->sp_max_since_gc) + if (new_sp >= vp->sp_min_since_gc) { vp->sp = new_sp; return; } - if (kind == VM_SP_PUSH && new_sp >= vp->stack_limit) + if (kind == VM_SP_PUSH && new_sp < vp->stack_limit) vm_expand_stack (vp, new_sp); else - vp->sp_max_since_gc = vp->sp = new_sp; + vp->sp_min_since_gc = vp->sp = new_sp; } static inline void -vm_push_sp (struct scm_vm *vp, SCM *new_sp) +vm_push_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp) { vm_increase_sp (vp, new_sp, VM_SP_PUSH); } static inline void -vm_restore_sp (struct scm_vm *vp, SCM *new_sp) +vm_restore_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp) { vm_increase_sp (vp, new_sp, VM_SP_RESTORE); } @@ -116,10 +115,12 @@ int scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame) { struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont); + union scm_vm_stack_element *stack_top; + stack_top = data->stack_bottom + data->stack_size; frame->stack_holder = data; - frame->fp_offset = (data->fp + data->reloc) - data->stack_base; - frame->sp_offset = (data->sp + data->reloc) - data->stack_base; + frame->fp_offset = stack_top - (data->fp + data->reloc); + frame->sp_offset = stack_top - (data->sp + data->reloc); frame->ip = data->ra; return 1; @@ -129,23 +130,25 @@ scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame) is inside VM code, and call/cc was invoked within that same call to vm_run. That's currently not implemented. */ SCM -scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra, +scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top, + union scm_vm_stack_element *fp, + union scm_vm_stack_element *sp, scm_t_uint32 *ra, scm_t_dynstack *dynstack, scm_t_uint32 flags) { struct scm_vm_cont *p; p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); - p->stack_size = sp - stack_base + 1; - p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), - "capture_vm_cont"); + p->stack_size = stack_top - sp; + p->stack_bottom = scm_gc_malloc (p->stack_size * sizeof (*p->stack_bottom), + "capture_vm_cont"); p->ra = ra; p->sp = sp; p->fp = fp; - memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM)); - p->reloc = p->stack_base - stack_base; + memcpy (p->stack_bottom, sp, p->stack_size * sizeof (*p->stack_bottom)); + p->reloc = (p->stack_bottom + p->stack_size) - stack_top; p->dynstack = dynstack; p->flags = flags; - return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p); + return scm_cell (scm_tc7_vm_cont, (scm_t_bits) p); } struct return_to_continuation_data @@ -162,23 +165,27 @@ vm_return_to_continuation_inner (void *data_ptr) struct return_to_continuation_data *data = data_ptr; struct scm_vm *vp = data->vp; struct scm_vm_cont *cp = data->cp; + union scm_vm_stack_element *cp_stack_top; scm_t_ptrdiff reloc; /* We know that there is enough space for the continuation, because we captured it in the past. However there may have been an expansion since the capture, so we may have to re-link the frame pointers. */ - reloc = (vp->stack_base - (cp->stack_base - cp->reloc)); + cp_stack_top = cp->stack_bottom + cp->stack_size; + reloc = (vp->stack_top - (cp_stack_top - cp->reloc)); vp->fp = cp->fp + reloc; - memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); + memcpy (vp->stack_top - cp->stack_size, + cp->stack_bottom, + cp->stack_size * sizeof (*cp->stack_bottom)); vm_restore_sp (vp, cp->sp + reloc); if (reloc) { - SCM *fp = vp->fp; + union scm_vm_stack_element *fp = vp->fp; while (fp) { - SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); + union scm_vm_stack_element *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); if (next_fp) { next_fp += reloc; @@ -192,14 +199,15 @@ vm_return_to_continuation_inner (void *data_ptr) } static void -vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv) +vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, + union scm_vm_stack_element *argv) { struct scm_vm_cont *cp; - SCM *argv_copy; + union scm_vm_stack_element *argv_copy; struct return_to_continuation_data data; - argv_copy = alloca (n * sizeof(SCM)); - memcpy (argv_copy, argv, n * sizeof(SCM)); + argv_copy = alloca (n * sizeof (*argv)); + memcpy (argv_copy, argv, n * sizeof (*argv)); cp = SCM_VM_CONT_DATA (cont); @@ -208,22 +216,13 @@ vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv) GC_call_with_alloc_lock (vm_return_to_continuation_inner, &data); /* Now we have the continuation properly copied over. We just need to - copy the arguments. It is not guaranteed that there is actually - space for the arguments, though, so we have to bump the SP first. */ - vm_push_sp (vp, vp->sp + 3 + n); - - /* Now copy on an empty frame and the return values, as the - continuation expects. */ - { - SCM *base = vp->sp + 1 - 3 - n; - size_t i; - - for (i = 0; i < 3; i++) - base[i] = SCM_BOOL_F; - - for (i = 0; i < n; i++) - base[i + 3] = argv_copy[i]; - } + copy on an empty frame and the return values, as the continuation + expects. */ + vm_push_sp (vp, vp->sp - 3 - n); + vp->sp[n+2].scm = SCM_BOOL_F; + vp->sp[n+1].scm = SCM_BOOL_F; + vp->sp[n].scm = SCM_BOOL_F; + memcpy(vp->sp, argv_copy, n * sizeof (union scm_vm_stack_element)); vp->ip = cp->ra; } @@ -238,19 +237,21 @@ scm_i_capture_current_stack (void) thread = SCM_I_CURRENT_THREAD; vp = thread_vm (thread); - return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, + return scm_i_vm_capture_stack (vp->stack_top, vp->fp, vp->sp, vp->ip, scm_dynstack_capture_all (&thread->dynstack), 0); } static void vm_dispatch_apply_hook (struct scm_vm *vp) SCM_NOINLINE; static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) SCM_NOINLINE; -static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) SCM_NOINLINE; +static void vm_dispatch_pop_continuation_hook + (struct scm_vm *vp, union scm_vm_stack_element *old_fp) SCM_NOINLINE; static void vm_dispatch_next_hook (struct scm_vm *vp) SCM_NOINLINE; static void vm_dispatch_abort_hook (struct scm_vm *vp) SCM_NOINLINE; static void -vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) +vm_dispatch_hook (struct scm_vm *vp, int hook_num, + union scm_vm_stack_element *argv, int n) { SCM hook; struct scm_frame c_frame; @@ -275,8 +276,8 @@ vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) seems reasonable to limit the lifetime of frame objects. */ c_frame.stack_holder = vp; - c_frame.fp_offset = vp->fp - vp->stack_base; - c_frame.sp_offset = vp->sp - vp->stack_base; + c_frame.fp_offset = vp->stack_top - vp->fp; + c_frame.sp_offset = vp->stack_top - vp->sp; c_frame.ip = vp->ip; /* Arrange for FRAME to be 8-byte aligned, like any other cell. */ @@ -298,15 +299,16 @@ vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) SCM args[2]; args[0] = SCM_PACK_POINTER (frame); - args[1] = argv[0]; + args[1] = argv[0].scm; scm_c_run_hookn (hook, args, 2); } else { SCM args = SCM_EOL; + int i; - while (n--) - args = scm_cons (argv[n], args); + for (i = 0; i < n; i++) + args = scm_cons (argv[i].scm, args); scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args)); } @@ -322,11 +324,11 @@ static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) { return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0); } -static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) +static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, + union scm_vm_stack_element *old_fp) { return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK, - &SCM_FRAME_LOCAL (old_fp, 1), - SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1); + vp->sp, SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1); } static void vm_dispatch_next_hook (struct scm_vm *vp) { @@ -335,38 +337,27 @@ static void vm_dispatch_next_hook (struct scm_vm *vp) static void vm_dispatch_abort_hook (struct scm_vm *vp) { return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK, - &SCM_FRAME_LOCAL (vp->fp, 1), - SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1); + vp->sp, SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1); } static void -vm_abort (struct scm_vm *vp, SCM tag, - size_t nstack, SCM *stack_args, SCM tail, SCM *sp, +vm_abort (struct scm_vm *vp, SCM tag, size_t nargs, scm_i_jmp_buf *current_registers) SCM_NORETURN; static void -vm_abort (struct scm_vm *vp, SCM tag, - size_t nstack, SCM *stack_args, SCM tail, SCM *sp, +vm_abort (struct scm_vm *vp, SCM tag, size_t nargs, scm_i_jmp_buf *current_registers) { size_t i; - ssize_t tail_len; SCM *argv; - tail_len = scm_ilength (tail); - if (tail_len < 0) - scm_misc_error ("vm-engine", "tail values to abort should be a list", - scm_list_1 (tail)); + argv = alloca (nargs * sizeof (SCM)); + for (i = 0; i < nargs; i++) + argv[i] = vp->sp[nargs - i - 1].scm; - argv = alloca ((nstack + tail_len) * sizeof (SCM)); - for (i = 0; i < nstack; i++) - argv[i] = stack_args[i]; - for (; i < nstack + tail_len; i++, tail = scm_cdr (tail)) - argv[i] = scm_car (tail); + vp->sp = vp->fp; - vp->sp = sp; - - scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers); + scm_c_abort (vp, tag, nargs, argv, current_registers); } struct vm_reinstate_partial_continuation_data @@ -382,23 +373,23 @@ vm_reinstate_partial_continuation_inner (void *data_ptr) struct vm_reinstate_partial_continuation_data *data = data_ptr; struct scm_vm *vp = data->vp; struct scm_vm_cont *cp = data->cp; - SCM *base; + union scm_vm_stack_element *base_fp; scm_t_ptrdiff reloc; - base = SCM_FRAME_LOCALS_ADDRESS (vp->fp); - reloc = cp->reloc + (base - cp->stack_base); + base_fp = vp->fp; + reloc = cp->reloc + (base_fp - (cp->stack_bottom + cp->stack_size)); - memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); + memcpy (base_fp - cp->stack_size, + cp->stack_bottom, + cp->stack_size * sizeof (*cp->stack_bottom)); vp->fp = cp->fp + reloc; vp->ip = cp->ra; /* now relocate frame pointers */ { - SCM *fp; - for (fp = vp->fp; - SCM_FRAME_LOWER_ADDRESS (fp) >= base; - fp = SCM_FRAME_DYNAMIC_LINK (fp)) + union scm_vm_stack_element *fp; + for (fp = vp->fp; fp < base_fp; fp = SCM_FRAME_DYNAMIC_LINK (fp)) SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc); } @@ -408,32 +399,32 @@ vm_reinstate_partial_continuation_inner (void *data_ptr) } static void -vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, - size_t n, SCM *argv, +vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs, scm_t_dynstack *dynstack, scm_i_jmp_buf *registers) { struct vm_reinstate_partial_continuation_data data; struct scm_vm_cont *cp; - SCM *argv_copy; + union scm_vm_stack_element *args; scm_t_ptrdiff reloc; - size_t i; - argv_copy = alloca (n * sizeof(SCM)); - memcpy (argv_copy, argv, n * sizeof(SCM)); + args = alloca (nargs * sizeof (*args)); + memcpy (args, vp->sp, nargs * sizeof (*args)); cp = SCM_VM_CONT_DATA (cont); - vm_push_sp (vp, SCM_FRAME_LOCALS_ADDRESS (vp->fp) + cp->stack_size + n - 1); + vm_push_sp (vp, vp->fp - (cp->stack_size + nargs + 1)); data.vp = vp; data.cp = cp; GC_call_with_alloc_lock (vm_reinstate_partial_continuation_inner, &data); reloc = data.reloc; - /* Push the arguments. */ - for (i = 0; i < n; i++) - vp->sp[i + 1 - n] = argv_copy[i]; + /* The resume continuation will expect ARGS on the stack as if from a + multiple-value return. Fill in the closure slot with #f, and copy + the arguments into place. */ + vp->sp[nargs].scm = SCM_BOOL_F; + memcpy (vp->sp, args, nargs * sizeof (*args)); /* The prompt captured a slice of the dynamic stack. Here we wind those entries onto the current thread's stack. We also have to @@ -789,20 +780,22 @@ typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp, static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] = { vm_regular_engine, vm_debug_engine }; -static SCM* +static union scm_vm_stack_element* allocate_stack (size_t size) -#define FUNC_NAME "make_vm" { void *ret; - if (size >= ((size_t) -1) / sizeof (SCM)) + if (size >= ((size_t) -1) / sizeof (union scm_vm_stack_element)) abort (); - size *= sizeof (SCM); + size *= sizeof (union scm_vm_stack_element); #if HAVE_SYS_MMAN_H ret = mmap (NULL, size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); + if (ret == NULL) + /* Shouldn't happen. */ + abort (); if (ret == MAP_FAILED) ret = NULL; #else @@ -810,19 +803,15 @@ allocate_stack (size_t size) #endif if (!ret) - { - perror ("allocate_stack failed"); - return NULL; - } + perror ("allocate_stack failed"); - return (SCM *) ret; + return (union scm_vm_stack_element *) ret; } -#undef FUNC_NAME static void -free_stack (SCM *stack, size_t size) +free_stack (union scm_vm_stack_element *stack, size_t size) { - size *= sizeof (SCM); + size *= sizeof (*stack); #if HAVE_SYS_MMAN_H munmap (stack, size); @@ -831,36 +820,38 @@ free_stack (SCM *stack, size_t size) #endif } -static SCM* -expand_stack (SCM *old_stack, size_t old_size, size_t new_size) +/* Ideally what we would like is an mremap or a realloc that grows at + the bottom, not the top. Oh well; mmap and memcpy are fast enough, + considering that they run very infrequently. */ +static union scm_vm_stack_element* +expand_stack (union scm_vm_stack_element *old_bottom, size_t old_size, + size_t new_size) #define FUNC_NAME "expand_stack" { -#if defined MREMAP_MAYMOVE - void *new_stack; + union scm_vm_stack_element *new_bottom; + size_t extension_size; - if (new_size >= ((size_t) -1) / sizeof (SCM)) + if (new_size >= ((size_t) -1) / sizeof (union scm_vm_stack_element)) + abort (); + if (new_size <= old_size) abort (); - old_size *= sizeof (SCM); - new_size *= sizeof (SCM); + extension_size = new_size - old_size; - new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE); - if (new_stack == MAP_FAILED) - return NULL; + if ((size_t)old_bottom < extension_size * sizeof (union scm_vm_stack_element)) + abort (); - return (SCM *) new_stack; -#else - SCM *new_stack; + new_bottom = allocate_stack (new_size); - new_stack = allocate_stack (new_size); - if (!new_stack) + if (!new_bottom) return NULL; - memcpy (new_stack, old_stack, old_size * sizeof (SCM)); - free_stack (old_stack, old_size); + memcpy (new_bottom + extension_size, + old_bottom, + old_size * sizeof (union scm_vm_stack_element)); + free_stack (old_bottom, old_size); - return new_stack; -#endif + return new_bottom; } #undef FUNC_NAME @@ -873,19 +864,21 @@ make_vm (void) vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); - vp->stack_size = page_size / sizeof (SCM); - vp->stack_base = allocate_stack (vp->stack_size); - if (!vp->stack_base) + vp->stack_size = page_size / sizeof (union scm_vm_stack_element); + vp->stack_bottom = allocate_stack (vp->stack_size); + if (!vp->stack_bottom) /* As in expand_stack, we don't have any way to throw an exception if we can't allocate one measely page -- there's no stack to handle it. For now, abort. */ abort (); - vp->stack_limit = vp->stack_base + vp->stack_size; + vp->stack_top = vp->stack_bottom + vp->stack_size; + vp->stack_limit = vp->stack_bottom; vp->overflow_handler_stack = SCM_EOL; - vp->ip = NULL; - vp->sp = vp->stack_base - 1; - vp->fp = NULL; - vp->engine = vm_default_engine; + vp->ip = NULL; + vp->sp = vp->stack_top; + vp->sp_min_since_gc = vp->sp; + vp->fp = NULL; + vp->engine = vm_default_engine; vp->trace_level = 0; for (i = 0; i < SCM_VM_NUM_HOOKS; i++) vp->hooks[i] = SCM_BOOL_F; @@ -898,30 +891,30 @@ static void return_unused_stack_to_os (struct scm_vm *vp) { #if HAVE_SYS_MMAN_H - scm_t_uintptr start = (scm_t_uintptr) (vp->sp + 1); - scm_t_uintptr end = (scm_t_uintptr) vp->stack_limit; + scm_t_uintptr lo = (scm_t_uintptr) vp->stack_bottom; + scm_t_uintptr hi = (scm_t_uintptr) vp->sp; /* The second condition is needed to protect against wrap-around. */ - if (vp->sp_max_since_gc < vp->stack_limit && vp->sp < vp->sp_max_since_gc) - end = (scm_t_uintptr) (vp->sp_max_since_gc + 1); + if (vp->sp_min_since_gc >= vp->stack_bottom && vp->sp >= vp->sp_min_since_gc) + lo = (scm_t_uintptr) vp->sp_min_since_gc; - start = ((start - 1U) | (page_size - 1U)) + 1U; /* round up */ - end = ((end - 1U) | (page_size - 1U)) + 1U; /* round up */ + lo &= ~(page_size - 1U); /* round down */ + hi &= ~(page_size - 1U); /* round down */ /* Return these pages to the OS. The next time they are paged in, they will be zeroed. */ - if (start < end) + if (lo < hi) { int ret = 0; do - ret = madvise ((void *) start, end - start, MADV_DONTNEED); + ret = madvise ((void *) lo, hi - lo, MADV_DONTNEED); while (ret && errno == -EAGAIN); if (ret) perror ("madvise failed"); } - vp->sp_max_since_gc = vp->sp; + vp->sp_min_since_gc = vp->sp; #endif } @@ -957,45 +950,44 @@ find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache) return map; } -/* Mark the VM stack region between its base and its current top. */ +/* Mark the active VM stack region. */ struct GC_ms_entry * scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, struct GC_ms_entry *mark_stack_limit) { - SCM *sp, *fp; + union scm_vm_stack_element *sp, *fp; /* The first frame will be marked conservatively (without a dead slot map). This is because GC can happen at any point within the hottest activation, due to multiple threads or per-instruction hooks, and providing dead slot maps for all points in a program would take a prohibitive amount of space. */ const scm_t_uint8 *dead_slots = NULL; - scm_t_uintptr upper = (scm_t_uintptr) GC_greatest_plausible_heap_addr; - scm_t_uintptr lower = (scm_t_uintptr) GC_least_plausible_heap_addr; + void *upper = (void *) GC_greatest_plausible_heap_addr; + void *lower = (void *) GC_least_plausible_heap_addr; struct dead_slot_map_cache cache; memset (&cache, 0, sizeof (cache)); for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp)) { - for (; sp >= &SCM_FRAME_LOCAL (fp, 0); sp--) + scm_t_ptrdiff nlocals = SCM_FRAME_NUM_LOCALS (fp, sp); + size_t slot = nlocals - 1; + for (slot = nlocals - 1; sp < fp; sp++, slot--) { - SCM elt = *sp; - if (SCM_NIMP (elt) - && SCM_UNPACK (elt) >= lower && SCM_UNPACK (elt) <= upper) + if (SCM_NIMP (sp->scm) && sp->ptr >= lower && sp->ptr <= upper) { if (dead_slots) { - size_t slot = sp - &SCM_FRAME_LOCAL (fp, 0); if (dead_slots[slot / 8U] & (1U << (slot % 8U))) { /* This value may become dead as a result of GC, so we can't just leave it on the stack. */ - *sp = SCM_UNSPECIFIED; + sp->scm = SCM_UNSPECIFIED; continue; } } - mark_stack_ptr = GC_mark_and_push ((void *) elt, + mark_stack_ptr = GC_mark_and_push (sp->ptr, mark_stack_ptr, mark_stack_limit, NULL); @@ -1018,8 +1010,8 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, void scm_i_vm_free_stack (struct scm_vm *vp) { - free_stack (vp->stack_base, vp->stack_size); - vp->stack_base = vp->stack_limit = NULL; + free_stack (vp->stack_bottom, vp->stack_size); + vp->stack_bottom = vp->stack_top = vp->stack_limit = NULL; vp->stack_size = 0; } @@ -1027,7 +1019,7 @@ struct vm_expand_stack_data { struct scm_vm *vp; size_t stack_size; - SCM *new_sp; + union scm_vm_stack_element *new_sp; }; static void * @@ -1036,34 +1028,35 @@ vm_expand_stack_inner (void *data_ptr) struct vm_expand_stack_data *data = data_ptr; struct scm_vm *vp = data->vp; - SCM *old_stack, *new_stack; + union scm_vm_stack_element *old_top, *new_bottom; size_t new_size; scm_t_ptrdiff reloc; + old_top = vp->stack_top; new_size = vp->stack_size; while (new_size < data->stack_size) new_size *= 2; - old_stack = vp->stack_base; - new_stack = expand_stack (vp->stack_base, vp->stack_size, new_size); - if (!new_stack) + new_bottom = expand_stack (vp->stack_bottom, vp->stack_size, new_size); + if (!new_bottom) return NULL; - vp->stack_base = new_stack; + vp->stack_bottom = new_bottom; vp->stack_size = new_size; - vp->stack_limit = vp->stack_base + new_size; - reloc = vp->stack_base - old_stack; + vp->stack_top = vp->stack_bottom + new_size; + vp->stack_limit = vp->stack_bottom; + reloc = vp->stack_top - old_top; if (reloc) { - SCM *fp; + union scm_vm_stack_element *fp; if (vp->fp) vp->fp += reloc; data->new_sp += reloc; fp = vp->fp; while (fp) { - SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); + union scm_vm_stack_element *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); if (next_fp) { next_fp += reloc; @@ -1073,7 +1066,7 @@ vm_expand_stack_inner (void *data_ptr) } } - return new_stack; + return new_bottom; } static scm_t_ptrdiff @@ -1095,9 +1088,9 @@ static void reset_stack_limit (struct scm_vm *vp) { if (should_handle_stack_overflow (vp, vp->stack_size)) - vp->stack_limit = vp->stack_base + current_overflow_size (vp); + vp->stack_limit = vp->stack_top - current_overflow_size (vp); else - vp->stack_limit = vp->stack_base + vp->stack_size; + vp->stack_limit = vp->stack_bottom; } struct overflow_handler_data @@ -1127,9 +1120,9 @@ unwind_overflow_handler (void *ptr) } static void -vm_expand_stack (struct scm_vm *vp, SCM *new_sp) +vm_expand_stack (struct scm_vm *vp, union scm_vm_stack_element *new_sp) { - scm_t_ptrdiff stack_size = new_sp + 1 - vp->stack_base; + scm_t_ptrdiff stack_size = vp->stack_top - new_sp; if (stack_size > vp->stack_size) { @@ -1146,7 +1139,7 @@ vm_expand_stack (struct scm_vm *vp, SCM *new_sp) new_sp = data.new_sp; } - vp->sp_max_since_gc = vp->sp = new_sp; + vp->sp_min_since_gc = vp->sp = new_sp; if (should_handle_stack_overflow (vp, stack_size)) { @@ -1184,7 +1177,7 @@ vm_expand_stack (struct scm_vm *vp, SCM *new_sp) scm_dynwind_end (); - /* Recurse */ + /* Recurse. */ return vm_expand_stack (vp, new_sp); } } @@ -1209,10 +1202,13 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) { scm_i_thread *thread; struct scm_vm *vp; - SCM *base; - ptrdiff_t base_frame_size; - /* Cached variables. */ - scm_i_jmp_buf registers; /* used for prompts */ + union scm_vm_stack_element *return_fp, *call_fp; + /* Since nargs can only describe the length of a valid argv array in + elements and each element is at least 4 bytes, nargs will not be + greater than INTMAX/2 and therefore we don't have to check for + overflow here or below. */ + size_t return_nlocals = 1, call_nlocals = nargs + 1, frame_size = 2; + scm_t_ptrdiff stack_reserve_words; size_t i; thread = SCM_I_CURRENT_THREAD; @@ -1220,32 +1216,36 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) SCM_CHECK_STACK; - /* Check that we have enough space: 3 words for the boot continuation, - and 3 + nargs for the procedure application. */ - base_frame_size = 3 + 3 + nargs; - vm_push_sp (vp, vp->sp + base_frame_size); - base = vp->sp + 1 - base_frame_size; - - /* Since it's possible to receive the arguments on the stack itself, - shuffle up the arguments first. */ - for (i = nargs; i > 0; i--) - base[6 + i - 1] = argv[i - 1]; - - /* Push the boot continuation, which calls PROC and returns its - result(s). */ - base[0] = SCM_PACK (vp->fp); /* dynamic link */ - base[1] = SCM_PACK (vp->ip); /* ra */ - base[2] = vm_boot_continuation; - vp->fp = &base[2]; + /* It's not valid for argv to point into the stack already. */ + if ((void *) argv < (void *) vp->stack_top && + (void *) argv >= (void *) vp->sp) + abort(); + + /* Check that we have enough space for the two stack frames: the + innermost one that makes the call, and its continuation which + receives the resulting value(s) and returns from the engine + call. */ + stack_reserve_words = call_nlocals + frame_size + return_nlocals + frame_size; + vm_push_sp (vp, vp->sp - stack_reserve_words); + + call_fp = vp->sp + call_nlocals; + return_fp = call_fp + frame_size + return_nlocals; + + SCM_FRAME_SET_RETURN_ADDRESS (return_fp, vp->ip); + SCM_FRAME_SET_DYNAMIC_LINK (return_fp, vp->fp); + SCM_FRAME_LOCAL (return_fp, 0) = vm_boot_continuation; + vp->ip = (scm_t_uint32 *) vm_boot_continuation_code; + vp->fp = call_fp; - /* The pending call to PROC. */ - base[3] = SCM_PACK (vp->fp); /* dynamic link */ - base[4] = SCM_PACK (vp->ip); /* ra */ - base[5] = proc; - vp->fp = &base[5]; + SCM_FRAME_SET_RETURN_ADDRESS (call_fp, vp->ip); + SCM_FRAME_SET_DYNAMIC_LINK (call_fp, return_fp); + SCM_FRAME_LOCAL (call_fp, 0) = proc; + for (i = 0; i < nargs; i++) + SCM_FRAME_LOCAL (call_fp, i + 1) = argv[i]; { + scm_i_jmp_buf registers; int resume = SCM_I_SETJMP (registers); if (SCM_UNLIKELY (resume)) @@ -1449,7 +1449,7 @@ SCM_DEFINE (scm_call_with_stack_overflow_handler, SCM new_limit, ret; vp = scm_the_vm (); - stack_size = vp->sp - vp->stack_base; + stack_size = vp->stack_top - vp->sp; c_limit = scm_to_ptrdiff_t (limit); if (c_limit <= 0) @@ -1474,7 +1474,7 @@ SCM_DEFINE (scm_call_with_stack_overflow_handler, scm_dynwind_unwind_handler (unwind_overflow_handler, &data, SCM_F_WIND_EXPLICITLY); - /* Reset vp->sp_max_since_gc so that the VM checks actually + /* Reset vp->sp_min_since_gc so that the VM checks actually trigger. */ return_unused_stack_to_os (vp); |