X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/9bd48cb17b4ce685f94f974442d452485a1017d6..2d026f04cc581915f62b1f2f3be2f27026ee383e:/libguile/vm.c diff --git a/libguile/vm.c b/libguile/vm.c index 2262aa280..831200fdf 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 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 @@ -23,13 +23,12 @@ #include #include #include -#include #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" @@ -73,98 +72,159 @@ * 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); +} + +/* 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. + */ static SCM -capture_vm_cont (struct scm_vm *vp) +vm_capture_continuation (SCM *stack_base, + SCM *fp, SCM *sp, scm_t_uint8 *ra, scm_t_uint8 *mvra) { - 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; + 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) + 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) { /* puts ("FIXME: Need to expand"); */ abort (); } #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 vm_capture_continuation (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL); } -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; + SCM frame; + + vp = SCM_VM_DATA (vm); + hook = vp->hooks[hook_num]; -static void enfalsen_frame (void *p) -{ - struct scm_vm *vp = p; - vp->trace_frame = SCM_BOOL_F; + if (SCM_LIKELY (scm_is_false (hook)) + || scm_is_null (SCM_HOOK_PROCEDURES (hook))) + return; + + vp->trace_level--; + frame = scm_c_make_frame (vm, vp->fp, vp->sp, vp->ip, 0); + scm_c_run_hookn (hook, &frame, 1); + vp->trace_level++; } +static void vm_abort (SCM vm, size_t n) SCM_NORETURN; static void -vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args) +vm_abort (SCM vm, size_t n) { - if (!scm_is_false (vp->trace_frame)) - return; - - 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); - - scm_c_run_hook (hook, hook_args); + size_t i; + ssize_t tail_len; + SCM tag, tail, *argv; + + /* FIXME: VM_ENABLE_STACK_NULLING */ + tail = *(SCM_VM_DATA (vm)->sp--); + /* NULLSTACK (1) */ + tail_len = scm_ilength (tail); + if (tail_len < 0) + abort (); + 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_dynwind_end (); + scm_c_abort (vm, tag, n + tail_len, argv); } @@ -172,9 +232,18 @@ 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; +SCM_SYMBOL (sym_vm_run, "vm-run"); +SCM_SYMBOL (sym_vm_error, "vm-error"); +SCM_SYMBOL (sym_keyword_argument_error, "keyword-argument-error"); +SCM_SYMBOL (sym_debug, "debug"); + +void +scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate) +{ + scm_puts ("#", port); +} static SCM really_make_boot_program (long nargs) @@ -190,12 +259,12 @@ really_make_boot_program (long nargs) text[1] = (scm_t_uint8)nargs; bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text)); - memcpy (bp->base, text, sizeof (text)); + memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text)); bp->len = sizeof(text); bp->metalen = 0; - u8vec = scm_take_u8vector ((scm_t_uint8*)bp, - sizeof (struct scm_objcode) + sizeof (text)); + u8vec = scm_c_take_bytevector ((scm_t_int8*)bp, + sizeof (struct scm_objcode) + sizeof (text)); ret = scm_make_program (scm_bytecode_to_objcode (u8vec), SCM_BOOL_F, SCM_BOOL_F); SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT); @@ -212,7 +281,7 @@ vm_make_boot_program (long nargs) { int i; for (i = 0; i < NUM_BOOT_PROGS; i++) - programs[i] = scm_permanent_object (really_make_boot_program (i)); + programs[i] = really_make_boot_program (i); } if (SCM_LIKELY (nargs < NUM_BOOT_PROGS)) @@ -254,7 +323,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 */ @@ -262,7 +331,6 @@ resolve_variable (SCM what, SCM program_module) } } - #define VM_DEFAULT_STACK_SIZE (64 * 1024) #define VM_NAME vm_regular_engine @@ -284,8 +352,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. */ @@ -300,16 +366,13 @@ make_vm (void) 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"); vp->stack_size = VM_DEFAULT_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. */ @@ -329,13 +392,12 @@ make_vm (void) 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->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 @@ -375,18 +437,19 @@ 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); + return vm_engines[vp->engine](vm, program, argv, nargs); } -SCM -scm_vm_apply (SCM vm, SCM program, SCM args) -#define FUNC_NAME "scm_vm_apply" +SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0, + (SCM vm, SCM program, SCM args), + "") +#define FUNC_NAME s_scm_vm_apply { SCM *argv; int i, nargs; SCM_VALIDATE_VM (1, vm); - SCM_VALIDATE_PROGRAM (2, program); + SCM_VALIDATE_PROC (2, program); nargs = scm_ilength (args); if (SCM_UNLIKELY (nargs < 0)) @@ -403,6 +466,12 @@ scm_vm_apply (SCM vm, SCM program, SCM args) } #undef FUNC_NAME +SCM +scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id) +{ + return scm_c_vm_run (vm, thunk, NULL, 0); +} + /* Scheme interface */ SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, @@ -421,7 +490,7 @@ SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0, { 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; @@ -482,7 +551,7 @@ 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]; \ } @@ -581,32 +650,24 @@ SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0, +SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0, (SCM vm), "") -#define FUNC_NAME s_scm_vm_stats +#define FUNC_NAME s_scm_vm_trace_level { - 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; + return scm_from_int (SCM_VM_DATA (vm)->trace_level); } #undef FUNC_NAME -SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 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_trace_frame +#define FUNC_NAME s_scm_set_vm_trace_level_x { SCM_VALIDATE_VM (1, vm); - return SCM_VM_DATA (vm)->trace_frame; + SCM_VM_DATA (vm)->trace_level = scm_to_int (level); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -626,34 +687,9 @@ SCM scm_load_compiled_with_vm (SCM file) void scm_bootstrap_vm (void) { - static int strappage = 0; - - if (strappage) - return; - - scm_bootstrap_frames (); - scm_bootstrap_instructions (); - scm_bootstrap_objcodes (); - scm_bootstrap_programs (); - - scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0); - - scm_tc16_vm = scm_make_smob_type ("vm", 0); - scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1); - - scm_c_define ("load-compiled", - scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0, - scm_load_compiled_with_vm)); - - 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")); - scm_c_register_extension ("libguile", "scm_init_vm", (scm_t_extension_init_func)scm_init_vm, NULL); - strappage = 1; - #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN vm_stack_gc_kind = GC_new_kind (GC_new_free_list (), @@ -666,8 +702,6 @@ scm_bootstrap_vm (void) void scm_init_vm (void) { - scm_bootstrap_vm (); - #ifndef SCM_MAGIC_SNARFER #include "libguile/vm.x" #endif