diff options
Diffstat (limited to 'libguile/vm.c')
-rw-r--r-- | libguile/vm.c | 161 |
1 files changed, 80 insertions, 81 deletions
diff --git a/libguile/vm.c b/libguile/vm.c index 6a4ecd8e4..ccc182afe 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -85,9 +85,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 @@ -103,7 +103,8 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) */ 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_t_uint8 *mvra, scm_t_dynstack *dynstack, + scm_t_uint32 flags) { struct scm_vm_cont *p; @@ -126,6 +127,7 @@ scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra, 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); } @@ -185,10 +187,19 @@ vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv) } 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; + SCM vm; + struct scm_vm *vp; + + thread = SCM_I_CURRENT_THREAD; + vm = scm_the_vm (); + vp = SCM_VM_DATA (vm); + + return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, + scm_dynstack_capture_all (&thread->dynstack), + 0); } static void @@ -230,17 +241,19 @@ vm_dispatch_hook (SCM vm, int hook_num) 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_1 = SCM_PACK_POINTER (&c_frame); + args[0] = SCM_PACK_POINTER (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_abort (SCM vm, size_t n, scm_t_int64 vm_cookie) +vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers) SCM_NORETURN; + +static void +vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers) { size_t i; ssize_t tail_len; @@ -263,16 +276,18 @@ vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie) /* NULLSTACK (n + 1) */ SCM_VM_DATA (vm)->sp -= n + 1; - scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie); + scm_c_abort (vm, tag, n + 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 (SCM vm, 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)); @@ -281,9 +296,10 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds, vp = SCM_VM_DATA (vm); cp = SCM_VM_CONT_DATA (cont); base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1; + reloc = cp->reloc + (base - cp->stack_base); #define RELOC(scm_p) \ - (((SCM *) (scm_p)) + cp->reloc + (base - cp->stack_base)) + (((SCM *) (scm_p)) + reloc) if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size) scm_misc_error ("vm-engine", @@ -314,30 +330,23 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds, 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. */ + /* 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 } @@ -354,22 +363,22 @@ scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate) vm = SCM_VM_DATA (x); - scm_puts ("#<vm ", port); + scm_puts_unlocked ("#<vm ", port); switch (vm->engine) { case SCM_VM_REGULAR_ENGINE: - scm_puts ("regular-engine ", port); + scm_puts_unlocked ("regular-engine ", port); break; case SCM_VM_DEBUG_ENGINE: - scm_puts ("debug-engine ", port); + scm_puts_unlocked ("debug-engine ", port); break; default: - scm_puts ("unknown-engine ", port); + scm_puts_unlocked ("unknown-engine ", port); } scm_uintprint (SCM_UNPACK (x), 16, port); - scm_puts (">", port); + scm_puts_unlocked (">", port); } @@ -378,36 +387,35 @@ 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_NORETURN; -static void vm_error_kwargs_unrecognized_keyword (SCM proc) 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; +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_NORETURN SCM_NOINLINE; +static void vm_error_kwargs_unrecognized_keyword (SCM proc) 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_overflow (struct scm_vm *vp) 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_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE; +static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE; #if VM_CHECK_IP -static void vm_error_invalid_address (void) SCM_NORETURN; +static void vm_error_invalid_address (void) SCM_NORETURN SCM_NOINLINE; #endif #if VM_CHECK_OBJECT -static void vm_error_object (void) SCM_NORETURN; +static void vm_error_object (void) SCM_NORETURN SCM_NOINLINE; #endif #if VM_CHECK_FREE_VARIABLES -static void vm_error_free_variable (void) SCM_NORETURN; +static void vm_error_free_variable (void) SCM_NORETURN SCM_NOINLINE; #endif static void @@ -449,13 +457,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", @@ -690,7 +691,7 @@ make_vm (void) /* 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 = SCM_PACK_POINTER (vp); vp->stack_base++; vp->stack_size--; #else @@ -709,7 +710,6 @@ 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); } #undef FUNC_NAME @@ -1058,9 +1058,8 @@ SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1, SCM scm_load_compiled_with_vm (SCM file) { - SCM program = scm_make_program (scm_load_objcode (file), - SCM_BOOL_F, SCM_BOOL_F); - + SCM program = scm_load_thunk_from_file (file); + return scm_c_vm_run (scm_the_vm (), program, NULL, 0); } @@ -1071,8 +1070,8 @@ make_boot_program (void) struct scm_objcode *bp; size_t bp_size; SCM u8vec, ret; - - const scm_t_uint8 text[] = { + + const scm_t_uint8 text[] = { scm_op_make_int8_1, scm_op_halt }; @@ -1083,8 +1082,8 @@ make_boot_program (void) 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), + u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size, SCM_BOOL_F); + ret = scm_make_program (scm_bytecode_to_objcode (u8vec, SCM_UNDEFINED), SCM_BOOL_F, SCM_BOOL_F); SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT)); |