X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/5f236208d0d864546e59afa0f5a11c9b3ba14b10..f0893308461d9586d4fd00d78fd7999a660058ff:/libguile/vm.c diff --git a/libguile/vm.c b/libguile/vm.c index 95aaa4fe4..d4c8b5fde 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 @@ -22,27 +22,32 @@ #include #include +#include #include -#include +#include -#include "libguile/boehm-gc.h" +#include "libguile/bdw-gc.h" #include #include "_scm.h" -#include "vm-bootstrap.h" +#include "control.h" #include "frames.h" #include "instructions.h" #include "objcodes.h" #include "programs.h" -#include "lang.h" /* NULL_OR_NIL_P */ #include "vm.h" -/* I sometimes use this for debugging. */ -#define vm_puts(OBJ) \ -{ \ - scm_display (OBJ, scm_current_error_port ()); \ - scm_newline (scm_current_error_port ()); \ -} +#include "private-gc.h" /* scm_getenv_int */ + +static int vm_default_engine = SCM_VM_REGULAR_ENGINE; + +/* Unfortunately we can't snarf these: snarfed things are only loaded up from + (system vm vm), which might not be loaded before an error happens. */ +static SCM sym_vm_run; +static SCM sym_vm_error; +static SCM sym_keyword_argument_error; +static SCM sym_regular; +static SCM sym_debug; /* 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. */ @@ -67,104 +72,274 @@ for a discussion. */ #define VM_ENABLE_PRECISE_STACK_GC_SCAN +/* 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 + /* * VM Continuation */ -scm_t_bits scm_tc16_vm_cont; +void +scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) +{ + scm_puts ("#", port); +} -static SCM -capture_vm_cont (struct scm_vm *vp) +/* In theory, a number of vm instances can be active in the call trace, and we + only want to reify the continuations of those in the current continuation + root. I don't see a nice way to do this -- ideally it would involve dynwinds, + and previous values of the *the-vm* fluid within the current continuation + root. But we don't have access to continuation roots in the dynwind stack. + So, just punt for now, we just capture the continuation for the current VM. + + While I'm on the topic, ideally we could avoid copying the C stack if the + continuation root is inside VM code, and call/cc was invoked within that same + 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) { - struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); - p->stack_size = vp->sp - vp->stack_base + 1; + 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"); -#ifdef VM_ENABLE_STACK_NULLING - if (vp->sp >= vp->stack_base) +#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->ip = vp->ip; - p->sp = vp->sp; - p->fp = vp->fp; - 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); + 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->flags = flags; + return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p); } static void -reinstate_vm_cont (struct scm_vm *vp, SCM cont) +vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv) { - struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont); - if (vp->stack_size < p->stack_size) - { - /* puts ("FIXME: Need to expand"); */ - abort (); - } + struct scm_vm *vp; + struct scm_vm_cont *cp; + SCM *argv_copy; + + 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)); + #ifdef VM_ENABLE_STACK_NULLING { - scm_t_ptrdiff nzero = (vp->sp - p->sp); + scm_t_ptrdiff nzero = (vp->sp - cp->sp); if (nzero > 0) - memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM)); + 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->ip = p->ip; - vp->sp = p->sp; - vp->fp = p->fp; - memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM)); -} + vp->sp = cp->sp; + vp->fp = cp->fp; + memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); -/* In theory, a number of vm instances can be active in the call trace, and we - only want to reify the continuations of those in the current continuation - root. I don't see a nice way to do this -- ideally it would involve dynwinds, - and previous values of the *the-vm* fluid within the current continuation - root. But we don't have access to continuation roots in the dynwind stack. - So, just punt for now -- take the current value of *the-vm*. + if (n == 1 || !cp->mvra) + { + vp->ip = cp->ra; + vp->sp++; + *vp->sp = argv_copy[0]; + } + else + { + size_t i; + for (i = 0; i < n; i++) + { + vp->sp++; + *vp->sp = argv_copy[i]; + } + vp->sp++; + *vp->sp = scm_from_size_t (n); + vp->ip = cp->mvra; + } +} - While I'm on the topic, ideally we could avoid copying the C stack if the - continuation root is inside VM code, and call/cc was invoked within that same - call to vm_run; but that's currently not implemented. - */ SCM -scm_vm_capture_continuations (void) +scm_i_vm_capture_continuation (SCM vm) { - SCM vm = scm_the_vm (); - return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL); + 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); } -void -scm_vm_reinstate_continuations (SCM conts) +static void +vm_dispatch_hook (SCM vm, int hook_num) { - for (; conts != SCM_EOL; conts = SCM_CDR (conts)) - reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts)); -} + 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)) + || scm_is_null (SCM_HOOK_PROCEDURES (hook))) + return; + + saved_trace_level = vp->trace_level; + vp->trace_level = 0; -static void enfalsen_frame (void *p) -{ - struct scm_vm *vp = p; - vp->trace_frame = SCM_BOOL_F; + /* Allocate a frame object on the stack. This is more efficient than calling + `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not + capture frame objects. + + At the same time, procedures such as `frame-procedure' make sense only + 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.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); + + scm_c_run_hookn (hook, args, 1); + + vp->trace_level = saved_trace_level; } +static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN; static void -vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args) +vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie) { - if (!SCM_FALSEP (vp->trace_frame)) - return; + size_t i; + ssize_t tail_len; + SCM tag, tail, *argv; - scm_dynwind_begin (0); - // FIXME, stack holder should be the vm - vp->trace_frame = scm_c_make_vm_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0); - scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY); + /* 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[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); +} + +static void +vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds, + size_t n, SCM *argv, scm_t_int64 vm_cookie) +{ + struct scm_vm *vp; + struct scm_vm_cont *cp; + SCM *argv_copy, *base; + size_t i; - scm_c_run_hook (hook, hook_args); + argv_copy = alloca (n * sizeof(SCM)); + memcpy (argv_copy, argv, n * sizeof(SCM)); - scm_dynwind_end (); + 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)) + + 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)); + + memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); + + /* now relocate frame pointers */ + { + SCM *fp; + for (fp = RELOC (cp->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))); + } + + 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. */ + for (i = 0; i < n; i++) + { + vp->sp++; + *vp->sp = argv_copy[i]; + } + vp->sp++; + *vp->sp = scm_from_size_t (n); + + /* 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. */ + { + long delta = 0; + SCM newwinds = scm_i_dynwinds (); + for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--) + { + 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_dowinds (newwinds, delta); + } +#undef RELOC } @@ -172,60 +347,276 @@ vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args) * VM Internal functions */ -static SCM sym_vm_run; -static SCM sym_vm_error; -static SCM sym_debug; +void +scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate) +{ + const struct scm_vm *vm; -static SCM -really_make_boot_program (long nargs) + vm = SCM_VM_DATA (x); + + scm_puts ("#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); +} + + +/* + * VM Error Handling + */ + +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 (const char *msg, SCM arg) { - SCM u8vec; - scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1, - scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop, - scm_op_halt }; - struct scm_objcode *bp; - SCM ret; + scm_throw (sym_vm_error, + scm_list_3 (sym_vm_run, scm_from_latin1_string (msg), + SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg))); + abort(); /* not reached */ +} - if (SCM_UNLIKELY (nargs > 255 || nargs < 0)) - abort (); - text[1] = (scm_t_uint8)nargs; +static void +vm_error_bad_instruction (scm_t_uint32 inst) +{ + vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst)); +} - bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text)); - memcpy (bp->base, text, sizeof (text)); - bp->nargs = 0; - bp->nrest = 0; - bp->nlocs = 0; - bp->len = sizeof(text); - bp->metalen = 0; - bp->unused = 0; +static void +vm_error_unbound (SCM proc, SCM sym) +{ + scm_error_scm (scm_misc_error_key, proc, + scm_from_latin1_string ("Unbound variable: ~s"), + scm_list_1 (sym), SCM_BOOL_F); +} - u8vec = scm_take_u8vector ((scm_t_uint8*)bp, - sizeof (struct scm_objcode) + sizeof (text)); - ret = scm_make_program (scm_bytecode_to_objcode (u8vec), - SCM_BOOL_F, SCM_BOOL_F); - SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT); +static void +vm_error_unbound_fluid (SCM proc, SCM fluid) +{ + scm_error_scm (scm_misc_error_key, proc, + scm_from_latin1_string ("Unbound fluid: ~s"), + scm_list_1 (fluid), SCM_BOOL_F); +} - return ret; +static void +vm_error_not_a_variable (const char *func_name, SCM x) +{ + scm_error (scm_arg_type_key, func_name, "Not a variable: ~S", + scm_list_1 (x), scm_list_1 (x)); } -#define NUM_BOOT_PROGS 8 -static SCM -vm_make_boot_program (long nargs) + +static void +vm_error_not_a_thunk (const char *func_name, SCM x) { - static SCM programs[NUM_BOOT_PROGS] = { 0, }; + scm_error (scm_arg_type_key, func_name, "Not a thunk: ~S", + scm_list_1 (x), scm_list_1 (x)); +} - if (SCM_UNLIKELY (!programs[0])) - { - int i; - for (i = 0; i < NUM_BOOT_PROGS; i++) - programs[i] = scm_permanent_object (really_make_boot_program (i)); - } - - if (SCM_LIKELY (nargs < NUM_BOOT_PROGS)) - return programs[nargs]; +static void +vm_error_apply_to_non_list (SCM x) +{ + scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S", + scm_list_1 (x), scm_list_1 (x)); +} + +static void +vm_error_kwargs_length_not_even (SCM proc) +{ + scm_error_scm (sym_keyword_argument_error, proc, + scm_from_latin1_string ("Odd length of keyword argument list"), + SCM_EOL, SCM_BOOL_F); +} + +static void +vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) +{ + scm_error_scm (sym_keyword_argument_error, proc, + scm_from_latin1_string ("Invalid keyword"), + SCM_EOL, scm_list_1 (obj)); +} + +static void +vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) +{ + scm_error_scm (sym_keyword_argument_error, proc, + scm_from_latin1_string ("Unrecognized keyword"), + SCM_EOL, scm_list_1 (kw)); +} + +static void +vm_error_too_many_args (int nargs) +{ + vm_error ("VM: Too many arguments", scm_from_int (nargs)); +} + +static void +vm_error_wrong_num_args (SCM proc) +{ + scm_wrong_num_args (proc); +} + +static void +vm_error_wrong_type_apply (SCM proc) +{ + scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S", + 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 - return really_make_boot_program (nargs); + /* 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) +{ + vm_error ("VM: Stack underflow", SCM_UNDEFINED); +} + +static void +vm_error_improper_list (SCM x) +{ + vm_error ("Expected a proper list, but got object with tail ~s", x); +} + +static void +vm_error_not_a_pair (const char *subr, SCM x) +{ + scm_wrong_type_arg_msg (subr, 1, x, "pair"); +} + +static void +vm_error_not_a_bytevector (const char *subr, SCM x) +{ + scm_wrong_type_arg_msg (subr, 1, x, "bytevector"); +} + +static void +vm_error_not_a_struct (const char *subr, SCM x) +{ + scm_wrong_type_arg_msg (subr, 1, x, "struct"); +} + +static void +vm_error_no_values (void) +{ + vm_error ("Zero values returned to single-valued continuation", + SCM_UNDEFINED); +} + +static void +vm_error_not_enough_values (void) +{ + vm_error ("Too few values returned to continuation", SCM_UNDEFINED); +} + +static void +vm_error_continuation_not_rewindable (SCM cont) +{ + vm_error ("Unrewindable partial continuation", cont); +} + +static void +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) +{ + vm_error ("VM: Invalid program address", SCM_UNDEFINED); +} +#endif + +#if VM_CHECK_OBJECT +static void +vm_error_object () +{ + vm_error ("VM: Invalid object table access", SCM_UNDEFINED); +} +#endif + +#if VM_CHECK_FREE_VARIABLES +static void +vm_error_free_variable () +{ + vm_error ("VM: Invalid free variable access", SCM_UNDEFINED); +} +#endif + + + +static SCM boot_continuation; + /* * VM @@ -234,20 +625,12 @@ vm_make_boot_program (long nargs) static SCM resolve_variable (SCM what, SCM program_module) { - if (SCM_LIKELY (SCM_SYMBOLP (what))) + if (SCM_LIKELY (scm_is_symbol (what))) { - if (SCM_LIKELY (scm_module_system_booted_p - && scm_is_true (program_module))) - /* might longjmp */ + if (scm_is_true (program_module)) return scm_module_lookup (program_module, what); else - { - SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); - if (scm_is_false (v)) - scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what)); - else - return v; - } + return scm_module_lookup (scm_the_root_module (), what); } else { @@ -259,7 +642,7 @@ resolve_variable (SCM what, SCM program_module) mod = scm_resolve_module (SCM_CAR (what)); if (scm_is_true (SCM_CADDR (what))) mod = scm_module_public_interface (mod); - if (SCM_FALSEP (mod)) + if (scm_is_false (mod)) scm_misc_error (NULL, "no such module: ~S", scm_list_1 (SCM_CAR (what))); /* might longjmp */ @@ -267,8 +650,17 @@ resolve_variable (SCM what, SCM program_module) } } - +#define VM_MIN_STACK_SIZE (1024) #define VM_DEFAULT_STACK_SIZE (64 * 1024) +static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE; + +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; +} #define VM_NAME vm_regular_engine #define FUNC_NAME "vm-regular-engine" @@ -289,8 +681,6 @@ resolve_variable (SCM what, SCM program_module) static const scm_t_vm_engine vm_engines[] = { vm_regular_engine, vm_debug_engine }; -scm_t_bits scm_tc16_vm; - #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN /* The GC "kind" for the VM stack. */ @@ -303,17 +693,15 @@ make_vm (void) #define FUNC_NAME "make_vm" { int i; + struct scm_vm *vp; - if (!scm_tc16_vm) - return SCM_BOOL_F; /* not booted yet */ + vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); - struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); - - vp->stack_size = VM_DEFAULT_STACK_SIZE; + vp->stack_size= vm_stack_size; #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN - vp->stack_base = GC_generic_malloc (vp->stack_size * sizeof (SCM), - vm_stack_gc_kind); + vp->stack_base = (SCM *) + GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind); /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack top is. */ @@ -328,18 +716,16 @@ make_vm (void) #ifdef VM_ENABLE_STACK_NULLING memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM)); #endif - vp->stack_limit = vp->stack_base + vp->stack_size; + vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE; vp->ip = NULL; vp->sp = vp->stack_base - 1; vp->fp = NULL; - vp->engine = SCM_VM_DEBUG_ENGINE; - vp->time = 0; - vp->clock = 0; - vp->options = SCM_EOL; + vp->engine = vm_default_engine; + vp->trace_level = 0; for (i = 0; i < SCM_VM_NUM_HOOKS; i++) vp->hooks[i] = SCM_BOOL_F; - vp->trace_frame = SCM_BOOL_F; - SCM_RETURN_NEWSMOB (scm_tc16_vm, vp); + vp->cookie = 0; + return scm_cell (scm_tc7_vm, (scm_t_bits)vp); } #undef FUNC_NAME @@ -357,8 +743,8 @@ vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, corresponding VM. */ vm = * ((struct scm_vm **) addr); - if ((SCM *) addr != vm->stack_base - 1 - || vm->stack_limit - vm->stack_base != vm->stack_size) + 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 ). */ return mark_stack_ptr; @@ -378,53 +764,20 @@ SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs) { struct scm_vm *vp = SCM_VM_DATA (vm); - return vm_engines[vp->engine](vp, program, argv, nargs); -} - -SCM -scm_vm_apply (SCM vm, SCM program, SCM args) -#define FUNC_NAME "scm_vm_apply" -{ - SCM *argv; - int i, nargs; - - SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_PROGRAM (2, program); - - 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); - } - - return scm_c_vm_run (vm, program, argv, nargs); + SCM_CHECK_STACK; + return vm_engines[vp->engine](vm, program, argv, nargs); } -#undef FUNC_NAME /* Scheme interface */ -SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, - (void), - "") -#define FUNC_NAME s_scm_vm_version -{ - return scm_from_locale_string (PACKAGE_VERSION); -} -#undef FUNC_NAME - SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0, (void), - "") + "Return the current thread's VM.") #define FUNC_NAME s_scm_the_vm { scm_i_thread *t = SCM_I_CURRENT_THREAD; - if (SCM_UNLIKELY (SCM_FALSEP ((t->vm)))) + if (SCM_UNLIKELY (scm_is_false (t->vm))) t->vm = make_vm (); return t->vm; @@ -437,7 +790,7 @@ SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0, "") #define FUNC_NAME s_scm_vm_p { - return SCM_BOOL (SCM_VM_P (obj)); + return scm_from_bool (SCM_VM_P (obj)); } #undef FUNC_NAME @@ -456,7 +809,7 @@ SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0, #define FUNC_NAME s_scm_vm_ip { SCM_VALIDATE_VM (1, vm); - return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip); + return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip); } #undef FUNC_NAME @@ -466,7 +819,7 @@ SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0, #define FUNC_NAME s_scm_vm_sp { SCM_VALIDATE_VM (1, vm); - return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp); + return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp); } #undef FUNC_NAME @@ -476,7 +829,7 @@ SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0, #define FUNC_NAME s_scm_vm_fp { SCM_VALIDATE_VM (1, vm); - return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp); + return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp); } #undef FUNC_NAME @@ -485,26 +838,35 @@ SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0, struct scm_vm *vp; \ SCM_VALIDATE_VM (1, vm); \ vp = SCM_VM_DATA (vm); \ - if (SCM_FALSEP (vp->hooks[n])) \ + 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_boot_hook, "vm-boot-hook", 1, 0, 0, +SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_apply_hook +{ + VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0, (SCM vm), "") -#define FUNC_NAME s_scm_vm_boot_hook +#define FUNC_NAME s_scm_vm_push_continuation_hook { - VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK); + VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0, +SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0, (SCM vm), "") -#define FUNC_NAME s_scm_vm_halt_hook +#define FUNC_NAME s_scm_vm_pop_continuation_hook { - VM_DEFINE_HOOK (SCM_VM_HALT_HOOK); + VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK); } #undef FUNC_NAME @@ -517,99 +879,190 @@ SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0, +SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0, (SCM vm), "") -#define FUNC_NAME s_scm_vm_break_hook +#define FUNC_NAME s_scm_vm_abort_continuation_hook { - VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK); + VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0, +SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0, (SCM vm), "") -#define FUNC_NAME s_scm_vm_enter_hook +#define FUNC_NAME s_scm_vm_restore_continuation_hook { - VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK); + VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, +SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0, (SCM vm), "") -#define FUNC_NAME s_scm_vm_apply_hook +#define FUNC_NAME s_scm_vm_trace_level { - VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); + SCM_VALIDATE_VM (1, vm); + return scm_from_int (SCM_VM_DATA (vm)->trace_level); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0, - (SCM vm), +SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0, + (SCM vm, SCM level), "") -#define FUNC_NAME s_scm_vm_exit_hook +#define FUNC_NAME s_scm_set_vm_trace_level_x { - VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK); + SCM_VALIDATE_VM (1, vm); + SCM_VM_DATA (vm)->trace_level = scm_to_int (level); + return SCM_UNSPECIFIED; } #undef FUNC_NAME -SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0, + +/* + * VM engines + */ + +static int +symbol_to_vm_engine (SCM engine, const char *FUNC_NAME) +{ + if (scm_is_eq (engine, sym_regular)) + return SCM_VM_REGULAR_ENGINE; + else if (scm_is_eq (engine, sym_debug)) + return SCM_VM_DEBUG_ENGINE; + else + SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine)); +} + +static SCM +vm_engine_to_symbol (int engine, const char *FUNC_NAME) +{ + switch (engine) + { + case SCM_VM_REGULAR_ENGINE: + return sym_regular; + case SCM_VM_DEBUG_ENGINE: + return sym_debug; + default: + /* ? */ + SCM_MISC_ERROR ("Unknown VM engine: ~a", + scm_list_1 (scm_from_int (engine))); + } +} + +SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0, (SCM vm), "") -#define FUNC_NAME s_scm_vm_return_hook +#define FUNC_NAME s_scm_vm_engine { - VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK); + SCM_VALIDATE_VM (1, vm); + return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0, - (SCM vm, SCM key), - "") -#define FUNC_NAME s_scm_vm_option +void +scm_c_set_vm_engine_x (SCM vm, int engine) +#define FUNC_NAME "set-vm-engine!" { SCM_VALIDATE_VM (1, vm); - return scm_assq_ref (SCM_VM_DATA (vm)->options, key); + + 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; } #undef FUNC_NAME -SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0, - (SCM vm, SCM key, SCM val), +SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0, + (SCM vm, SCM engine), "") -#define FUNC_NAME s_scm_set_vm_option_x +#define FUNC_NAME s_scm_set_vm_engine_x { - SCM_VALIDATE_VM (1, vm); - SCM_VM_DATA (vm)->options - = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val); + scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME)); return SCM_UNSPECIFIED; } #undef FUNC_NAME -SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0, - (SCM vm), - "") -#define FUNC_NAME s_scm_vm_stats +void +scm_c_set_default_vm_engine_x (int engine) +#define FUNC_NAME "set-default-vm-engine!" { - SCM stats; - - SCM_VALIDATE_VM (1, vm); - - stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED); - scm_vector_set_x (stats, SCM_I_MAKINUM (0), - scm_from_ulong (SCM_VM_DATA (vm)->time)); - scm_vector_set_x (stats, SCM_I_MAKINUM (1), - scm_from_ulong (SCM_VM_DATA (vm)->clock)); - - return stats; + if (engine < 0 || engine >= SCM_VM_NUM_ENGINES) + SCM_MISC_ERROR ("Unknown VM engine: ~a", + scm_list_1 (scm_from_int (engine))); + + vm_default_engine = engine; } #undef FUNC_NAME -SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0, - (SCM vm), +SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0, + (SCM engine), "") -#define FUNC_NAME s_scm_vm_trace_frame +#define FUNC_NAME s_scm_set_default_vm_engine_x +{ + scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME)); + return SCM_UNSPECIFIED; +} +#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), + "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}.") +#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); - return SCM_VM_DATA (vm)->trace_frame; + 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; } #undef FUNC_NAME @@ -626,36 +1079,49 @@ SCM scm_load_compiled_with_vm (SCM file) return scm_c_vm_run (scm_the_vm (), program, NULL, 0); } -void -scm_bootstrap_vm (void) -{ - static int strappage = 0; - if (strappage) - return; - - scm_bootstrap_frames (); - scm_bootstrap_instructions (); - scm_bootstrap_objcodes (); - scm_bootstrap_programs (); +static SCM +make_boot_program (void) +{ + struct scm_objcode *bp; + size_t bp_size; + SCM u8vec, ret; - scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0); + const scm_t_uint8 text[] = { + scm_op_make_int8_1, + scm_op_halt + }; - scm_tc16_vm = scm_make_smob_type ("vm", 0); - scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1); + 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; - scm_c_define ("load-compiled", - scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0, - scm_load_compiled_with_vm)); + 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)); - sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run")); - sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error")); - sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug")); + return ret; +} - scm_c_register_extension ("libguile", "scm_init_vm", +void +scm_bootstrap_vm (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_vm", (scm_t_extension_init_func)scm_init_vm, NULL); - strappage = 1; + initialize_default_stack_size (); + + sym_vm_run = scm_from_latin1_symbol ("vm-run"); + sym_vm_error = scm_from_latin1_symbol ("vm-error"); + sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error"); + sym_regular = scm_from_latin1_symbol ("regular"); + sym_debug = scm_from_latin1_symbol ("debug"); + + boot_continuation = make_boot_program (); #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN vm_stack_gc_kind = @@ -669,8 +1135,6 @@ scm_bootstrap_vm (void) void scm_init_vm (void) { - scm_bootstrap_vm (); - #ifndef SCM_MAGIC_SNARFER #include "libguile/vm.x" #endif