diff options
Diffstat (limited to 'libguile/vm.c')
-rw-r--r-- | libguile/vm.c | 1271 |
1 files changed, 738 insertions, 533 deletions
diff --git a/libguile/vm.c b/libguile/vm.c index d4c8b5fde..b0918b6bf 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -16,6 +16,9 @@ * 02110-1301 USA */ +/* For mremap(2) on GNU/Linux systems. */ +#define _GNU_SOURCE + #if HAVE_CONFIG_H # include <config.h> #endif @@ -25,6 +28,11 @@ #include <alignof.h> #include <string.h> #include <stdint.h> +#include <unistd.h> + +#ifdef HAVE_SYS_MMAN_H +#include <sys/mman.h> +#endif #include "libguile/bdw-gc.h" #include <gc/gc_mark.h> @@ -32,12 +40,13 @@ #include "_scm.h" #include "control.h" #include "frames.h" +#include "gc-inline.h" #include "instructions.h" -#include "objcodes.h" +#include "loader.h" #include "programs.h" +#include "simpos.h" #include "vm.h" - -#include "private-gc.h" /* scm_getenv_int */ +#include "vm-builtins.h" static int vm_default_engine = SCM_VM_REGULAR_ENGINE; @@ -53,29 +62,38 @@ static SCM sym_debug; 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. Slows down the VM by about 30%. */ -/* NB! If you enable this, search for NULLING in throw.c */ -/* #define VM_ENABLE_STACK_NULLING */ - /* #define VM_ENABLE_PARANOID_ASSERTIONS */ -#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS) -#define VM_ENABLE_ASSERTIONS -#endif +static void vm_expand_stack (struct scm_vm *vp) 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 + may expand the stack. */ +enum vm_increase_sp_kind { VM_SP_PUSH, VM_SP_RESTORE }; -/* When defined, arrange so that the GC doesn't scan the VM stack beyond its - current SP. This should help avoid excess data retention. See - http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001 - for a discussion. */ -#define VM_ENABLE_PRECISE_STACK_GC_SCAN +static inline void +vm_increase_sp (struct scm_vm *vp, SCM *new_sp, enum vm_increase_sp_kind kind) +{ + vp->sp = new_sp; + if (new_sp > vp->sp_max_since_gc) + { + vp->sp_max_since_gc = new_sp; + if (kind == VM_SP_PUSH && new_sp >= vp->stack_limit) + vm_expand_stack (vp); + } +} -/* Size in SCM objects of the stack reserve. The reserve is used to run - exception handling code in case of a VM stack overflow. */ -#define VM_STACK_RESERVE_SIZE 512 +static inline void +vm_push_sp (struct scm_vm *vp, SCM *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_increase_sp (vp, new_sp, VM_SP_RESTORE); +} /* @@ -85,9 +103,9 @@ static SCM sym_debug; void scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) { - scm_puts ("#<vm-continuation ", port); + scm_puts_unlocked ("#<vm-continuation ", port); scm_uintprint (SCM_UNPACK (x), 16, port); - scm_puts (">", port); + scm_puts_unlocked (">", port); } /* In theory, a number of vm instances can be active in the call trace, and we @@ -102,8 +120,8 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) call to vm_run; but that's currently not implemented. */ SCM -scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra, - scm_t_uint8 *mvra, scm_t_uint32 flags) +scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra, + scm_t_dynstack *dynstack, scm_t_uint32 flags) { struct scm_vm_cont *p; @@ -111,97 +129,106 @@ scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra, p->stack_size = sp - stack_base + 1; p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), "capture_vm_cont"); -#if defined(VM_ENABLE_STACK_NULLING) && 0 - /* Tail continuations leave their frame on the stack for subsequent - application, but don't capture the frame -- so there are some elements on - the stack then, and this check doesn't work, so disable it for now. */ - if (sp >= vp->stack_base) - if (!vp->sp[0] || vp->sp[1]) - abort (); - memset (p->stack_base, 0, p->stack_size * sizeof (SCM)); -#endif p->ra = ra; - p->mvra = mvra; 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; + p->dynstack = dynstack; p->flags = flags; return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p); } static void -vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv) +vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv) { - struct scm_vm *vp; struct scm_vm_cont *cp; SCM *argv_copy; + scm_t_ptrdiff reloc; argv_copy = alloca (n * sizeof(SCM)); memcpy (argv_copy, argv, n * sizeof(SCM)); - vp = SCM_VM_DATA (vm); cp = SCM_VM_CONT_DATA (cont); - if (n == 0 && !cp->mvra) - scm_misc_error (NULL, "Too few values returned to continuation", - SCM_EOL); - - if (vp->stack_size < cp->stack_size + n + 1) - scm_misc_error ("vm-engine", "not enough space to reinstate continuation", - scm_list_2 (vm, cont)); + /* FIXME: Need to prevent GC while futzing with the stack; otherwise, + another thread causing GC may initiate a mark of a stack in an + inconsistent state. */ -#ifdef VM_ENABLE_STACK_NULLING - { - scm_t_ptrdiff nzero = (vp->sp - cp->sp); - if (nzero > 0) - memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM)); - /* actually nzero should always be negative, because vm_reset_stack will - unwind the stack to some point *below* this continuation */ - } -#endif - vp->sp = cp->sp; - vp->fp = cp->fp; + /* 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)); + vp->fp = cp->fp + reloc; memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); + vm_restore_sp (vp, cp->sp + reloc); - if (n == 1 || !cp->mvra) - { - vp->ip = cp->ra; - vp->sp++; - *vp->sp = argv_copy[0]; - } - else + if (reloc) { - size_t i; - for (i = 0; i < n; i++) + SCM *fp = vp->fp; + while (fp) { - vp->sp++; - *vp->sp = argv_copy[i]; + SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); + if (next_fp) + { + next_fp += reloc; + SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp); + } + fp = next_fp; } - vp->sp++; - *vp->sp = scm_from_size_t (n); - vp->ip = cp->mvra; } + + /* 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]; + } + + vp->ip = cp->ra; } +static struct scm_vm * thread_vm (scm_i_thread *t); SCM -scm_i_vm_capture_continuation (SCM vm) +scm_i_capture_current_stack (void) { - struct scm_vm *vp = SCM_VM_DATA (vm); - return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, 0); + scm_i_thread *thread; + struct scm_vm *vp; + + thread = SCM_I_CURRENT_THREAD; + vp = thread_vm (thread); + + return scm_i_vm_capture_stack (vp->stack_base, 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_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 (SCM vm, int hook_num) +vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) { - struct scm_vm *vp; SCM hook; struct scm_frame c_frame; scm_t_cell *frame; - SCM args[1]; int saved_trace_level; - vp = SCM_VM_DATA (vm); hook = vp->hooks[hook_num]; if (SCM_LIKELY (scm_is_false (hook)) @@ -219,157 +246,159 @@ vm_dispatch_hook (SCM vm, int hook_num) while the stack frame represented by the frame object is visible, so it seems reasonable to limit the lifetime of frame objects. */ - c_frame.stack_holder = vm; - c_frame.fp = vp->fp; - c_frame.sp = vp->sp; + 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.ip = vp->ip; - c_frame.offset = 0; /* Arrange for FRAME to be 8-byte aligned, like any other cell. */ frame = alloca (sizeof (*frame) + 8); frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL); - frame->word_0 = SCM_PACK (scm_tc7_frame); - frame->word_1 = PTR2SCM (&c_frame); - args[0] = PTR2SCM (frame); + frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8)); + frame->word_1 = SCM_PACK_POINTER (&c_frame); - scm_c_run_hookn (hook, args, 1); + if (n == 0) + { + SCM args[1]; + + args[0] = SCM_PACK_POINTER (frame); + scm_c_run_hookn (hook, args, 1); + } + else if (n == 1) + { + SCM args[2]; + + args[0] = SCM_PACK_POINTER (frame); + args[1] = argv[0]; + scm_c_run_hookn (hook, args, 2); + } + else + { + SCM args = SCM_EOL; + + while (n--) + args = scm_cons (argv[n], args); + scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args)); + } vp->trace_level = saved_trace_level; } -static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN; static void -vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie) +vm_dispatch_apply_hook (struct scm_vm *vp) +{ + return vm_dispatch_hook (vp, SCM_VM_APPLY_HOOK, NULL, 0); +} +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) +{ + 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); +} +static void vm_dispatch_next_hook (struct scm_vm *vp) +{ + return vm_dispatch_hook (vp, SCM_VM_NEXT_HOOK, NULL, 0); +} +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); +} + +static void +vm_abort (struct scm_vm *vp, SCM tag, + size_t nstack, SCM *stack_args, SCM tail, SCM *sp, + 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, + scm_i_jmp_buf *current_registers) { size_t i; ssize_t tail_len; - SCM tag, tail, *argv; + SCM *argv; - /* FIXME: VM_ENABLE_STACK_NULLING */ - tail = *(SCM_VM_DATA (vm)->sp--); - /* NULLSTACK (1) */ 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)); - tag = SCM_VM_DATA (vm)->sp[-n]; - argv = alloca ((n + tail_len) * sizeof (SCM)); - for (i = 0; i < n; i++) - argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)]; - for (; i < n + tail_len; i++, tail = scm_cdr (tail)) + 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); - /* NULLSTACK (n + 1) */ - SCM_VM_DATA (vm)->sp -= n + 1; - scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie); + /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */ + vp->sp = sp; + + scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers); } static void -vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds, - size_t n, SCM *argv, scm_t_int64 vm_cookie) +vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, + size_t n, SCM *argv, + scm_t_dynstack *dynstack, + scm_i_jmp_buf *registers) { - struct scm_vm *vp; struct scm_vm_cont *cp; SCM *argv_copy, *base; + scm_t_ptrdiff reloc; size_t i; argv_copy = alloca (n * sizeof(SCM)); memcpy (argv_copy, argv, n * sizeof(SCM)); - vp = SCM_VM_DATA (vm); cp = SCM_VM_CONT_DATA (cont); - base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1; -#define RELOC(scm_p) \ - (((SCM *) (scm_p)) + cp->reloc + (base - cp->stack_base)) + vm_push_sp (vp, SCM_FRAME_LOCALS_ADDRESS (vp->fp) + cp->stack_size + n - 1); - if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size) - scm_misc_error ("vm-engine", - "not enough space to instate partial continuation", - scm_list_2 (vm, cont)); + base = SCM_FRAME_LOCALS_ADDRESS (vp->fp); + reloc = cp->reloc + (base - cp->stack_base); memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); + vp->fp = cp->fp + reloc; + vp->ip = cp->ra; + /* now relocate frame pointers */ { SCM *fp; - for (fp = RELOC (cp->fp); + for (fp = vp->fp; SCM_FRAME_LOWER_ADDRESS (fp) > base; fp = SCM_FRAME_DYNAMIC_LINK (fp)) - SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp))); + SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc); } - vp->sp = base - 1 + cp->stack_size; - vp->fp = RELOC (cp->fp); - vp->ip = cp->mvra; - - /* now push args. ip is in a MV context. */ + /* Push the arguments. */ for (i = 0; i < n; i++) - { - vp->sp++; - *vp->sp = argv_copy[i]; - } - vp->sp++; - *vp->sp = scm_from_size_t (n); + vp->sp[i + 1 - n] = argv_copy[i]; - /* Finally, rewind the dynamic state. - - We have to treat prompts specially, because we could be rewinding the - dynamic state from a different thread, or just a different position on the - C and/or VM stack -- so we need to reset the jump buffers so that an abort - comes back here, with appropriately adjusted sp and fp registers. */ + /* The prompt captured a slice of the dynamic stack. Here we wind + those entries onto the current thread's stack. We also have to + relocate any prompts that we see along the way. */ { - long delta = 0; - SCM newwinds = scm_i_dynwinds (); - for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--) + scm_t_bits *walk; + + for (walk = SCM_DYNSTACK_FIRST (cp->dynstack); + SCM_DYNSTACK_TAG (walk); + walk = SCM_DYNSTACK_NEXT (walk)) { - SCM x = scm_car (intwinds); - if (SCM_PROMPT_P (x)) - /* the jmpbuf will be reset by our caller */ - x = scm_c_make_prompt (SCM_PROMPT_TAG (x), - RELOC (SCM_PROMPT_REGISTERS (x)->fp), - RELOC (SCM_PROMPT_REGISTERS (x)->sp), - SCM_PROMPT_REGISTERS (x)->ip, - SCM_PROMPT_ESCAPE_P (x), - vm_cookie, - newwinds); - newwinds = scm_cons (x, newwinds); + scm_t_bits tag = SCM_DYNSTACK_TAG (walk); + + if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) + scm_dynstack_wind_prompt (dynstack, walk, reloc, registers); + else + scm_dynstack_wind_1 (dynstack, walk); } - scm_dowinds (newwinds, delta); } -#undef RELOC -} - - -/* - * VM Internal functions - */ - -void -scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate) -{ - const struct scm_vm *vm; - - vm = SCM_VM_DATA (x); - - scm_puts ("#<vm ", port); - switch (vm->engine) - { - case SCM_VM_REGULAR_ENGINE: - scm_puts ("regular-engine ", port); - break; - - case SCM_VM_DEBUG_ENGINE: - scm_puts ("debug-engine ", port); - break; - - default: - scm_puts ("unknown-engine ", port); - } - scm_uintprint (SCM_UNPACK (x), 16, port); - scm_puts (">", port); } @@ -378,37 +407,27 @@ scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate) */ static void vm_error (const char *msg, SCM arg) SCM_NORETURN; -static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN; -static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN; -static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN; -static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN; -static void vm_error_not_a_thunk (const char *func_name, SCM x) SCM_NORETURN; -static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN; -static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN; -static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN; -static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN; -static void vm_error_too_many_args (int nargs) SCM_NORETURN; -static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN; -static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN; -static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN; -static void vm_error_stack_underflow (void) SCM_NORETURN; -static void vm_error_improper_list (SCM x) SCM_NORETURN; -static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN; -static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN; -static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN; -static void vm_error_no_values (void) SCM_NORETURN; -static void vm_error_not_enough_values (void) SCM_NORETURN; -static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN; -static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN; -#if VM_CHECK_IP -static void vm_error_invalid_address (void) SCM_NORETURN; -#endif -#if VM_CHECK_OBJECT -static void vm_error_object (void) SCM_NORETURN; -#endif -#if VM_CHECK_FREE_VARIABLES -static void vm_error_free_variable (void) SCM_NORETURN; -#endif +static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE; +static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN SCM_NOINLINE; +static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE; +static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE; +static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE; +static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE; +static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE; +static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; +static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE; +static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; +static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE; +static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE; +static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE; static void vm_error (const char *msg, SCM arg) @@ -449,13 +468,6 @@ vm_error_not_a_variable (const char *func_name, SCM x) } static void -vm_error_not_a_thunk (const char *func_name, SCM x) -{ - scm_error (scm_arg_type_key, func_name, "Not a thunk: ~S", - scm_list_1 (x), scm_list_1 (x)); -} - -static void vm_error_apply_to_non_list (SCM x) { scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S", @@ -505,35 +517,6 @@ vm_error_wrong_type_apply (SCM proc) scm_list_1 (proc), scm_list_1 (proc)); } -/* Reinstate the stack reserve in the VM pointed to by DATA. */ -static void -reinstate_stack_reserve (void *data) -{ - struct scm_vm *vp = data; - - vp->stack_limit -= VM_STACK_RESERVE_SIZE; -} - -static void -vm_error_stack_overflow (struct scm_vm *vp) -{ - if (vp->stack_limit < vp->stack_base + vp->stack_size) - /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so - that `throw' below can run on this VM. */ - vp->stack_limit = vp->stack_base + vp->stack_size; - else - /* There is no space left on the stack. FIXME: Do something more - sensible here! */ - abort (); - - /* Before throwing, install a handler that reinstates the reserve so - that subsequent overflows are gracefully handled. */ - scm_dynwind_begin (0); - scm_dynwind_unwind_handler (reinstate_stack_reserve, vp, 0); - vm_error ("VM: Stack overflow", SCM_UNDEFINED); - scm_dynwind_end (); -} - static void vm_error_stack_underflow (void) { @@ -578,6 +561,13 @@ vm_error_not_enough_values (void) } static void +vm_error_wrong_number_of_values (scm_t_uint32 expected) +{ + vm_error ("Wrong number of values returned to continuation (expected ~a)", + scm_from_uint32 (expected)); +} + +static void vm_error_continuation_not_rewindable (SCM cont) { vm_error ("Unrewindable partial continuation", cont); @@ -589,134 +579,246 @@ vm_error_bad_wide_string_length (size_t len) vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len)); } -#ifdef VM_CHECK_IP -static void -vm_error_invalid_address (void) + + + +static SCM vm_boot_continuation; +static SCM vm_builtin_apply; +static SCM vm_builtin_values; +static SCM vm_builtin_abort_to_prompt; +static SCM vm_builtin_call_with_values; +static SCM vm_builtin_call_with_current_continuation; + +static const scm_t_uint32 vm_boot_continuation_code[] = { + SCM_PACK_OP_24 (halt, 0) +}; + +static const scm_t_uint32 vm_builtin_apply_code[] = { + SCM_PACK_OP_24 (assert_nargs_ge, 3), + SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */ +}; + +static const scm_t_uint32 vm_builtin_values_code[] = { + SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ +}; + +static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = { + SCM_PACK_OP_24 (assert_nargs_ge, 2), + SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */ + /* FIXME: Partial continuation should capture caller regs. */ + SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ +}; + +static const scm_t_uint32 vm_builtin_call_with_values_code[] = { + SCM_PACK_OP_24 (assert_nargs_ee, 3), + SCM_PACK_OP_24 (alloc_frame, 7), + SCM_PACK_OP_12_12 (mov, 6, 1), + SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1), + SCM_PACK_OP_12_12 (mov, 0, 2), + SCM_PACK_OP_24 (tail_call_shuffle, 7) +}; + +static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = { + SCM_PACK_OP_24 (assert_nargs_ee, 2), + SCM_PACK_OP_24 (call_cc, 0) +}; + + +static SCM +scm_vm_builtin_ref (unsigned idx) { - vm_error ("VM: Invalid program address", SCM_UNDEFINED); + switch (idx) + { +#define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \ + case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin; + FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) +#undef INDEX_TO_NAME + default: abort(); + } } -#endif -#if VM_CHECK_OBJECT -static void -vm_error_object () +SCM scm_sym_apply; +static SCM scm_sym_values; +static SCM scm_sym_abort_to_prompt; +static SCM scm_sym_call_with_values; +static SCM scm_sym_call_with_current_continuation; + +SCM +scm_vm_builtin_name_to_index (SCM name) +#define FUNC_NAME "builtin-name->index" { - vm_error ("VM: Invalid object table access", SCM_UNDEFINED); + SCM_VALIDATE_SYMBOL (1, name); + +#define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \ + if (scm_is_eq (name, scm_sym_##builtin)) \ + return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN); + FOR_EACH_VM_BUILTIN(NAME_TO_INDEX) +#undef NAME_TO_INDEX + + return SCM_BOOL_F; } -#endif +#undef FUNC_NAME -#if VM_CHECK_FREE_VARIABLES -static void -vm_error_free_variable () +SCM +scm_vm_builtin_index_to_name (SCM index) +#define FUNC_NAME "builtin-index->name" { - vm_error ("VM: Invalid free variable access", SCM_UNDEFINED); + unsigned idx; + + SCM_VALIDATE_UINT_COPY (1, index, idx); + + switch (idx) + { +#define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \ + case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin; + FOR_EACH_VM_BUILTIN(INDEX_TO_NAME) +#undef INDEX_TO_NAME + default: return SCM_BOOL_F; + } } -#endif +#undef FUNC_NAME - +static void +scm_init_vm_builtins (void) +{ + scm_c_define_gsubr ("builtin-name->index", 1, 0, 0, + scm_vm_builtin_name_to_index); + scm_c_define_gsubr ("builtin-index->name", 1, 0, 0, + scm_vm_builtin_index_to_name); +} -static SCM boot_continuation; +SCM +scm_i_call_with_current_continuation (SCM proc) +{ + return scm_call_1 (vm_builtin_call_with_current_continuation, proc); +} /* * VM */ -static SCM -resolve_variable (SCM what, SCM program_module) -{ - if (SCM_LIKELY (scm_is_symbol (what))) - { - if (scm_is_true (program_module)) - return scm_module_lookup (program_module, what); - else - return scm_module_lookup (scm_the_root_module (), what); - } - else - { - SCM mod; - /* compilation of @ or @@ - `what' is a three-element list: (MODNAME SYM INTERFACE?) - INTERFACE? is #t if we compiled @ or #f if we compiled @@ - */ - mod = scm_resolve_module (SCM_CAR (what)); - if (scm_is_true (SCM_CADDR (what))) - mod = scm_module_public_interface (mod); - if (scm_is_false (mod)) - scm_misc_error (NULL, "no such module: ~S", - scm_list_1 (SCM_CAR (what))); - /* might longjmp */ - return scm_module_lookup (mod, SCM_CADR (what)); - } -} - -#define VM_MIN_STACK_SIZE (1024) -#define VM_DEFAULT_STACK_SIZE (64 * 1024) -static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE; +/* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on + 64-bit machines. */ +static const size_t hard_max_stack_size = 512 * 1024 * 1024; + +/* Initial stack size: 4 or 8 kB. */ +static const size_t initial_stack_size = 1024; + +/* Default soft stack limit is 1M words (4 or 8 megabytes). */ +static size_t default_max_stack_size = 1024 * 1024; static void initialize_default_stack_size (void) { - int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size); - if (size >= VM_MIN_STACK_SIZE) - vm_stack_size = size; + int size = scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size); + if (size >= initial_stack_size && (size_t) size < ((size_t) -1) / sizeof(SCM)) + default_max_stack_size = size; } -#define VM_NAME vm_regular_engine +#define VM_NAME vm_regular_engine +#define VM_USE_HOOKS 0 #define FUNC_NAME "vm-regular-engine" -#define VM_ENGINE SCM_VM_REGULAR_ENGINE #include "vm-engine.c" -#undef VM_NAME #undef FUNC_NAME -#undef VM_ENGINE +#undef VM_USE_HOOKS +#undef VM_NAME -#define VM_NAME vm_debug_engine +#define VM_NAME vm_debug_engine +#define VM_USE_HOOKS 1 #define FUNC_NAME "vm-debug-engine" -#define VM_ENGINE SCM_VM_DEBUG_ENGINE #include "vm-engine.c" -#undef VM_NAME #undef FUNC_NAME -#undef VM_ENGINE +#undef VM_USE_HOOKS +#undef VM_NAME -static const scm_t_vm_engine vm_engines[] = +typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp, + scm_i_jmp_buf *registers, int resume); + +static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] = { vm_regular_engine, vm_debug_engine }; -#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN +static SCM* +allocate_stack (size_t size) +#define FUNC_NAME "make_vm" +{ + void *ret; + + if (size >= ((size_t) -1) / sizeof (SCM)) + abort (); -/* The GC "kind" for the VM stack. */ -static int vm_stack_gc_kind; + size *= sizeof (SCM); +#if HAVE_SYS_MMAN_H + ret = mmap (NULL, size, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); + if (ret == MAP_FAILED) + SCM_SYSERROR; +#else + ret = malloc (size); + if (!ret) + SCM_SYSERROR; #endif -static SCM -make_vm (void) -#define FUNC_NAME "make_vm" + return (SCM *) ret; +} +#undef FUNC_NAME + +static void +free_stack (SCM *stack, size_t size) { - int i; - struct scm_vm *vp; + size *= sizeof (SCM); - vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); +#if HAVE_SYS_MMAN_H + munmap (stack, size); +#else + free (stack); +#endif +} + +static SCM* +expand_stack (SCM *old_stack, size_t old_size, size_t new_size) +#define FUNC_NAME "expand_stack" +{ +#if defined MREMAP_MAYMOVE + void *new_stack; + + if (new_size >= ((size_t) -1) / sizeof (SCM)) + abort (); - vp->stack_size= vm_stack_size; + old_size *= sizeof (SCM); + new_size *= sizeof (SCM); -#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN - vp->stack_base = (SCM *) - GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind); + new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE); + if (new_stack == MAP_FAILED) + SCM_SYSERROR; - /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack - top is. */ - *vp->stack_base = PTR2SCM (vp); - vp->stack_base++; - vp->stack_size--; + return (SCM *) new_stack; #else - vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM), - "stack-base"); -#endif + SCM *new_stack; + + new_stack = allocate_stack (new_size); + memcpy (new_stack, old_stack, old_size * sizeof (SCM)); + free_stack (old_stack, old_size); -#ifdef VM_ENABLE_STACK_NULLING - memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM)); + return new_stack; #endif - vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE; +} +#undef FUNC_NAME + +static struct scm_vm * +make_vm (void) +#define FUNC_NAME "make_vm" +{ + int i; + struct scm_vm *vp; + + vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); + + vp->stack_size = initial_stack_size; + vp->stack_base = allocate_stack (vp->stack_size); + vp->stack_limit = vp->stack_base + vp->stack_size; + vp->max_stack_size = default_max_stack_size; vp->ip = NULL; vp->sp = vp->stack_base - 1; vp->fp = NULL; @@ -724,127 +826,289 @@ make_vm (void) vp->trace_level = 0; for (i = 0; i < SCM_VM_NUM_HOOKS; i++) vp->hooks[i] = SCM_BOOL_F; - vp->cookie = 0; - return scm_cell (scm_tc7_vm, (scm_t_bits)vp); + + return vp; } #undef FUNC_NAME -#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN +static size_t page_size; -/* Mark the VM stack region between its base and its current top. */ -static struct GC_ms_entry * -vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, - struct GC_ms_entry *mark_stack_limit, GC_word env) +static void +return_unused_stack_to_os (struct scm_vm *vp) { - GC_word *word; - const struct scm_vm *vm; +#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; + /* 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); - /* The first word of the VM stack should contain a pointer to the - corresponding VM. */ - vm = * ((struct scm_vm **) addr); + start = ((start - 1U) | (page_size - 1U)) + 1U; /* round up */ + end = ((end - 1U) | (page_size - 1U)) + 1U; /* round up */ - if (vm == NULL - || (SCM *) addr != vm->stack_base - 1) - /* ADDR must be a pointer to a free-list element, which we must ignore - (see warning in <gc/gc_mark.h>). */ - return mark_stack_ptr; + /* Return these pages to the OS. The next time they are paged in, + they will be zeroed. */ + if (start < end) + madvise ((void *) start, end - start, MADV_DONTNEED); - for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++) - mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word), - mark_stack_ptr, mark_stack_limit, - NULL); - - return mark_stack_ptr; + vp->sp_max_since_gc = vp->sp; +#endif } -#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */ - - -SCM -scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs) +#define DEAD_SLOT_MAP_CACHE_SIZE 32U +struct dead_slot_map_cache_entry { - struct scm_vm *vp = SCM_VM_DATA (vm); - SCM_CHECK_STACK; - return vm_engines[vp->engine](vm, program, argv, nargs); -} + scm_t_uint32 *ip; + const scm_t_uint8 *map; +}; -/* Scheme interface */ +struct dead_slot_map_cache +{ + struct dead_slot_map_cache_entry entries[DEAD_SLOT_MAP_CACHE_SIZE]; +}; -SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0, - (void), - "Return the current thread's VM.") -#define FUNC_NAME s_scm_the_vm +static const scm_t_uint8 * +find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache) { - scm_i_thread *t = SCM_I_CURRENT_THREAD; + /* The lower two bits should be zero. FIXME: Use a better hash + function; we don't expose scm_raw_hashq currently. */ + size_t slot = (((scm_t_uintptr) ip) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE; + const scm_t_uint8 *map; - if (SCM_UNLIKELY (scm_is_false (t->vm))) - t->vm = make_vm (); + if (cache->entries[slot].ip == ip) + map = cache->entries[slot].map; + else + { + map = scm_find_dead_slot_map_unlocked (ip); + cache->entries[slot].ip = ip; + cache->entries[slot].map = map; + } - return t->vm; + return map; } -#undef FUNC_NAME +/* Mark the VM stack region between its base and its current top. */ +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; + /* 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; + 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 elt = *sp; + if (SCM_NIMP (elt) + && SCM_UNPACK (elt) >= lower && SCM_UNPACK (elt) <= 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_UNBOUND; + continue; + } + } + + mark_stack_ptr = GC_mark_and_push ((void *) elt, + mark_stack_ptr, + mark_stack_limit, + NULL); + } + } + sp = SCM_FRAME_PREVIOUS_SP (fp); + /* Inner frames may have a dead slots map for precise marking. + Note that there may be other reasons to not have a dead slots + map, e.g. if all of the frame's slots below the callee frame + are live. */ + dead_slots = find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache); + } -SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0, - (SCM obj), - "") -#define FUNC_NAME s_scm_vm_p + return_unused_stack_to_os (vp); + + return mark_stack_ptr; +} + +/* Free the VM stack, as this thread is exiting. */ +void +scm_i_vm_free_stack (struct scm_vm *vp) { - return scm_from_bool (SCM_VM_P (obj)); + free_stack (vp->stack_base, vp->stack_size); + vp->stack_base = vp->stack_limit = NULL; + vp->stack_size = 0; } -#undef FUNC_NAME -SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0, - (void), - "") -#define FUNC_NAME s_scm_make_vm, +static void +vm_expand_stack (struct scm_vm *vp) { - return make_vm (); + scm_t_ptrdiff stack_size = vp->sp + 1 - vp->stack_base; + + if (stack_size > hard_max_stack_size) + { + /* We have expanded the soft limit to the point that we reached a + hard limit. There is nothing sensible to do. */ + fprintf (stderr, "Hard stack size limit (%zu words) reached; aborting.\n", + hard_max_stack_size); + abort (); + } + + /* FIXME: Prevent GC while we expand the stack, to ensure that a + stack marker can trace the stack. */ + if (stack_size > vp->stack_size) + { + SCM *old_stack; + size_t new_size; + scm_t_ptrdiff reloc; + + new_size = vp->stack_size; + while (new_size < stack_size) + new_size *= 2; + old_stack = vp->stack_base; + vp->stack_base = expand_stack (old_stack, vp->stack_size, new_size); + vp->stack_size = new_size; + vp->stack_limit = vp->stack_base + new_size; + reloc = vp->stack_base - old_stack; + + if (reloc) + { + SCM *fp; + if (vp->fp) + vp->fp += reloc; + vp->sp += reloc; + vp->sp_max_since_gc += reloc; + fp = vp->fp; + while (fp) + { + SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); + if (next_fp) + { + next_fp += reloc; + SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp); + } + fp = next_fp; + } + } + } + + if (stack_size >= vp->max_stack_size) + { + /* Expand the soft limit by 256K entries to give us space to + handle the error. */ + vp->max_stack_size += 256 * 1024; + + /* If it's still not big enough... it's quite improbable, but go + ahead and set to the full available stack size. */ + if (vp->max_stack_size < stack_size) + vp->max_stack_size = vp->stack_size; + + /* But don't exceed the hard maximum. */ + if (vp->max_stack_size > hard_max_stack_size) + vp->max_stack_size = hard_max_stack_size; + + /* Finally, reset the limit, to catch further overflows. */ + vp->stack_limit = vp->stack_base + vp->max_stack_size; + + vm_error ("VM: Stack overflow", SCM_UNDEFINED); + } + + /* Otherwise continue, with the new enlarged stack. */ } -#undef FUNC_NAME -SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0, - (SCM vm), - "") -#define FUNC_NAME s_scm_vm_ip +static struct scm_vm * +thread_vm (scm_i_thread *t) { - SCM_VALIDATE_VM (1, vm); - return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip); + if (SCM_UNLIKELY (!t->vp)) + t->vp = make_vm (); + + return t->vp; } -#undef FUNC_NAME -SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0, - (SCM vm), - "") -#define FUNC_NAME s_scm_vm_sp +struct scm_vm * +scm_the_vm (void) { - SCM_VALIDATE_VM (1, vm); - return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp); + return thread_vm (SCM_I_CURRENT_THREAD); } -#undef FUNC_NAME -SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0, - (SCM vm), - "") -#define FUNC_NAME s_scm_vm_fp +SCM +scm_call_n (SCM proc, SCM *argv, size_t nargs) { - SCM_VALIDATE_VM (1, vm); - return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp); + 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 */ + size_t i; + + thread = SCM_I_CURRENT_THREAD; + vp = thread_vm (thread); + + 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]; + vp->ip = (scm_t_uint32 *) vm_boot_continuation_code; + + /* 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]; + + { + int resume = SCM_I_SETJMP (registers); + + if (SCM_UNLIKELY (resume)) + /* Non-local return. */ + vm_dispatch_abort_hook (vp); + + return vm_engines[vp->engine](thread, vp, ®isters, resume); + } } -#undef FUNC_NAME + +/* Scheme interface */ #define VM_DEFINE_HOOK(n) \ { \ struct scm_vm *vp; \ - SCM_VALIDATE_VM (1, vm); \ - vp = SCM_VM_DATA (vm); \ + vp = scm_the_vm (); \ if (scm_is_false (vp->hooks[n])) \ vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \ return vp->hooks[n]; \ } -SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, - (SCM vm), +SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0, + (void), "") #define FUNC_NAME s_scm_vm_apply_hook { @@ -852,8 +1116,8 @@ SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0, - (SCM vm), +SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0, 0, + (void), "") #define FUNC_NAME s_scm_vm_push_continuation_hook { @@ -861,8 +1125,8 @@ SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0, - (SCM vm), +SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0, + (void), "") #define FUNC_NAME s_scm_vm_pop_continuation_hook { @@ -870,8 +1134,8 @@ SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, - (SCM vm), +SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0, + (void), "") #define FUNC_NAME s_scm_vm_next_hook { @@ -879,8 +1143,8 @@ SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0, - (SCM vm), +SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0, 0, 0, + (void), "") #define FUNC_NAME s_scm_vm_abort_continuation_hook { @@ -888,32 +1152,21 @@ SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0, - (SCM vm), - "") -#define FUNC_NAME s_scm_vm_restore_continuation_hook -{ - VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0, - (SCM vm), +SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0, + (void), "") #define FUNC_NAME s_scm_vm_trace_level { - SCM_VALIDATE_VM (1, vm); - return scm_from_int (SCM_VM_DATA (vm)->trace_level); + return scm_from_int (scm_the_vm ()->trace_level); } #undef FUNC_NAME -SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0, - (SCM vm, SCM level), +SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0, + (SCM level), "") #define FUNC_NAME s_scm_set_vm_trace_level_x { - SCM_VALIDATE_VM (1, vm); - SCM_VM_DATA (vm)->trace_level = scm_to_int (level); + scm_the_vm ()->trace_level = scm_to_int (level); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -950,36 +1203,33 @@ vm_engine_to_symbol (int engine, const char *FUNC_NAME) } } -SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0, - (SCM vm), +SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0, + (void), "") #define FUNC_NAME s_scm_vm_engine { - SCM_VALIDATE_VM (1, vm); - return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME); + return vm_engine_to_symbol (scm_the_vm ()->engine, FUNC_NAME); } #undef FUNC_NAME void -scm_c_set_vm_engine_x (SCM vm, int engine) +scm_c_set_vm_engine_x (int engine) #define FUNC_NAME "set-vm-engine!" { - SCM_VALIDATE_VM (1, vm); - if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (scm_from_int (engine))); - SCM_VM_DATA (vm)->engine = engine; + scm_the_vm ()->engine = engine; } #undef FUNC_NAME -SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0, - (SCM vm, SCM engine), +SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0, + (SCM engine), "") #define FUNC_NAME s_scm_set_vm_engine_x { - scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME)); + scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1006,63 +1256,15 @@ SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0, } #undef FUNC_NAME -static void reinstate_vm (SCM vm) -{ - scm_i_thread *t = SCM_I_CURRENT_THREAD; - t->vm = vm; -} - -SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1, - (SCM vm, SCM proc, SCM args), +/* FIXME: This function makes no sense, but we keep it to make sure we + have a way of switching to the debug or regular VM. */ +SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1, + (SCM proc, SCM args), "Apply @var{proc} to @var{args} in a dynamic extent in which\n" - "@var{vm} is the current VM.\n\n" - "As an implementation restriction, if @var{vm} is not the same\n" - "as the current thread's VM, continuations captured within the\n" - "call to @var{proc} may not be reinstated once control leaves\n" - "@var{proc}.") + "@var{vm} is the current VM.") #define FUNC_NAME s_scm_call_with_vm { - SCM prev_vm, ret; - SCM *argv; - int i, nargs; - scm_t_wind_flags flags; - scm_i_thread *t = SCM_I_CURRENT_THREAD; - - SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_PROC (2, proc); - - nargs = scm_ilength (args); - if (SCM_UNLIKELY (nargs < 0)) - scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list"); - - argv = alloca (nargs * sizeof(SCM)); - for (i = 0; i < nargs; i++) - { - argv[i] = SCM_CAR (args); - args = SCM_CDR (args); - } - - prev_vm = t->vm; - - /* Reentry can happen via invokation of a saved continuation, but - continuations only save the state of the VM that they are in at - capture-time, which might be different from this one. So, in the - case that the VMs are different, set up a non-rewindable frame to - prevent reinstating an incomplete continuation. */ - flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY; - if (flags) - { - scm_dynwind_begin (0); - scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags); - t->vm = vm; - } - - ret = scm_c_vm_run (vm, proc, argv, nargs); - - if (flags) - scm_dynwind_end (); - - return ret; + return scm_apply_0 (proc, args); } #undef FUNC_NAME @@ -1071,39 +1273,33 @@ SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1, * Initialize */ -SCM scm_load_compiled_with_vm (SCM file) +SCM +scm_load_compiled_with_vm (SCM file) { - SCM program = scm_make_program (scm_load_objcode (file), - SCM_BOOL_F, SCM_BOOL_F); - - return scm_c_vm_run (scm_the_vm (), program, NULL, 0); + return scm_call_0 (scm_load_thunk_from_file (file)); } -static SCM -make_boot_program (void) -{ - struct scm_objcode *bp; - size_t bp_size; - SCM u8vec, ret; - - const scm_t_uint8 text[] = { - scm_op_make_int8_1, - scm_op_halt - }; - - bp_size = sizeof (struct scm_objcode) + sizeof (text); - bp = scm_gc_malloc_pointerless (bp_size, "boot-program"); - memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text)); - bp->len = sizeof(text); - bp->metalen = 0; - - u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size); - ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec), - SCM_BOOL_F, SCM_BOOL_F); - SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT)); - - return ret; +void +scm_init_vm_builtin_properties (void) +{ + /* FIXME: Seems hacky to do this here, but oh well :/ */ + scm_sym_apply = scm_from_utf8_symbol ("apply"); + scm_sym_values = scm_from_utf8_symbol ("values"); + scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt"); + scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values"); + scm_sym_call_with_current_continuation = + scm_from_utf8_symbol ("call-with-current-continuation"); + +#define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \ + scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \ + scm_sym_##builtin); \ + scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \ + SCM_I_MAKINUM (req), \ + SCM_I_MAKINUM (opt), \ + scm_from_bool (rest)); + FOR_EACH_VM_BUILTIN (INIT_BUILTIN); +#undef INIT_BUILTIN } void @@ -1112,6 +1308,15 @@ scm_bootstrap_vm (void) scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_vm", (scm_t_extension_init_func)scm_init_vm, NULL); + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_vm_builtins", + (scm_t_extension_init_func)scm_init_vm_builtins, + NULL); + + page_size = getpagesize (); + /* page_size should be a power of two. */ + if (page_size & (page_size - 1)) + abort (); initialize_default_stack_size (); @@ -1121,15 +1326,15 @@ scm_bootstrap_vm (void) sym_regular = scm_from_latin1_symbol ("regular"); sym_debug = scm_from_latin1_symbol ("debug"); - boot_continuation = make_boot_program (); + vm_boot_continuation = scm_i_make_program (vm_boot_continuation_code); + SCM_SET_CELL_WORD_0 (vm_boot_continuation, + (SCM_CELL_WORD_0 (vm_boot_continuation) + | SCM_F_PROGRAM_IS_BOOT)); -#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN - vm_stack_gc_kind = - GC_new_kind (GC_new_free_list (), - GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0), - 0, 1); - -#endif +#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \ + vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code); + FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN); +#undef DEFINE_BUILTIN } void |