X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/b7393ea123eb0f27d99ba1c38bd944f78b90eb42..81b80b9610798ea910daad78cf525dec211639f9:/libguile/vm-engine.c diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 34764c659..c90458df6 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,34 +1,33 @@ -/* Copyright (C) 2001 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011 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 as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* This file is included in vm.c multiple times */ #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE) #define VM_USE_HOOKS 0 /* Various hooks */ -#define VM_USE_CLOCK 0 /* Bogoclock */ -#define VM_CHECK_EXTERNAL 1 /* Check external link */ -#define VM_CHECK_OBJECT 1 /* Check object table */ -#define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */ +#define VM_CHECK_OBJECT 0 /* Check object table */ +#define VM_CHECK_FREE_VARIABLES 0 /* Check free variable access */ +#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */ #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) #define VM_USE_HOOKS 1 -#define VM_USE_CLOCK 1 -#define VM_CHECK_EXTERNAL 1 -#define VM_CHECK_OBJECT 1 -#define VM_PUSH_DEBUG_FRAMES 1 +#define VM_CHECK_OBJECT 0 +#define VM_CHECK_FREE_VARIABLES 0 +#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */ #else #error unknown debug engine VM_ENGINE #endif @@ -37,54 +36,56 @@ static SCM -VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) +VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) { /* VM registers */ - register scm_byte_t *ip IP_REG; /* instruction pointer */ + register scm_t_uint8 *ip IP_REG; /* instruction pointer */ register SCM *sp SP_REG; /* stack pointer */ register SCM *fp FP_REG; /* frame pointer */ + struct scm_vm *vp = SCM_VM_DATA (vm); /* Cache variables */ struct scm_objcode *bp = NULL; /* program base pointer */ - SCM external = SCM_EOL; /* external environment */ SCM *objects = NULL; /* constant objects */ +#if VM_CHECK_OBJECT size_t object_count = 0; /* length of OBJECTS */ - SCM *stack_base = vp->stack_base; /* stack base address */ +#endif SCM *stack_limit = vp->stack_limit; /* stack limit address */ + scm_i_thread *current_thread = SCM_I_CURRENT_THREAD; + scm_t_int64 vm_cookie = vp->cookie++; + /* Internal variables */ int nvalues = 0; - long start_time = scm_c_get_internal_run_time (); + const char *func_name = NULL; /* used for error reporting */ SCM finish_args; /* used both for returns: both in error and normal situations */ -#if VM_USE_HOOKS - SCM hook_args = SCM_EOL; -#endif - #ifdef HAVE_LABELS_AS_VALUES - static void **jump_table = NULL; -#endif - -#if VM_PUSH_DEBUG_FRAMES - scm_t_debug_frame debug; - scm_t_debug_info debug_vect_body; - debug.status = SCM_VOIDFRAME; + static const void **jump_table_pointer = NULL; #endif #ifdef HAVE_LABELS_AS_VALUES - if (SCM_UNLIKELY (!jump_table)) + register const void **jump_table JT_REG; + + if (SCM_UNLIKELY (!jump_table_pointer)) { int i; - jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*)); + jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*)); for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) - jump_table[i] = &&vm_error_bad_instruction; + jump_table_pointer[i] = &&vm_error_bad_instruction; #define VM_INSTRUCTION_TO_LABEL 1 +#define jump_table jump_table_pointer #include #include #include #include +#undef jump_table #undef VM_INSTRUCTION_TO_LABEL } + + /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one + load instruction at each instruction dispatch. */ + jump_table = jump_table_pointer; #endif /* Initialization */ @@ -94,22 +95,19 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) /* Boot program */ program = vm_make_boot_program (nargs); -#if VM_PUSH_DEBUG_FRAMES - debug.prev = scm_i_last_debug_frame (); - debug.status = SCM_APPLYFRAME; - debug.vect = &debug_vect_body; - debug.vect[0].a.proc = program; /* the boot program */ - debug.vect[0].a.args = SCM_EOL; - scm_i_set_last_debug_frame (&debug); -#endif - /* Initial frame */ CACHE_REGISTER (); + PUSH (SCM_PACK (fp)); /* dynamic link */ + PUSH (SCM_PACK (0)); /* mvra */ + PUSH (SCM_PACK (ip)); /* ra */ CACHE_PROGRAM (); PUSH (program); - NEW_FRAME (); - - /* Initial arguments */ + fp = sp + 1; + ip = SCM_C_OBJCODE_BASE (bp); + /* MV-call frame, function & arguments */ + PUSH (SCM_PACK (0)); /* dynamic link */ + PUSH (SCM_PACK (0)); /* mvra */ + PUSH (SCM_PACK (0)); /* ra */ PUSH (prog); if (SCM_UNLIKELY (sp + nargs >= stack_limit)) goto vm_error_too_many_args; @@ -118,7 +116,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) } /* Let's go! */ - BOOT_HOOK (); NEXT; #ifndef HAVE_LABELS_AS_VALUES @@ -140,31 +137,68 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) vm_done: SYNC_ALL (); -#if VM_PUSH_DEBUG_FRAMES - scm_i_set_last_debug_frame (debug.prev); -#endif return finish_args; /* Errors */ { SCM err_msg; + /* FIXME: need to sync regs before allocating anything, in each case. */ + vm_error_bad_instruction: - err_msg = scm_from_locale_string ("VM: Bad instruction: ~A"); + err_msg = scm_from_latin1_string ("VM: Bad instruction: ~s"); finish_args = scm_list_1 (scm_from_uchar (ip[-1])); goto vm_error; vm_error_unbound: - err_msg = scm_from_locale_string ("VM: Unbound variable: ~A"); + /* FINISH_ARGS should be the name of the unbound variable. */ + SYNC_ALL (); + err_msg = scm_from_latin1_string ("Unbound variable: ~s"); + scm_error_scm (scm_misc_error_key, program, err_msg, + scm_list_1 (finish_args), SCM_BOOL_F); goto vm_error; - vm_error_wrong_type_arg: - err_msg = scm_from_locale_string ("VM: Wrong type argument"); - finish_args = SCM_EOL; + vm_error_unbound_fluid: + SYNC_ALL (); + err_msg = scm_from_latin1_string ("Unbound fluid: ~s"); + scm_error_scm (scm_misc_error_key, program, err_msg, + scm_list_1 (finish_args), SCM_BOOL_F); + goto vm_error; + + vm_error_not_a_variable: + SYNC_ALL (); + scm_error (scm_arg_type_key, func_name, "Not a variable: ~S", + scm_list_1 (finish_args), scm_list_1 (finish_args)); + goto vm_error; + + vm_error_apply_to_non_list: + SYNC_ALL (); + scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S", + scm_list_1 (finish_args), scm_list_1 (finish_args)); goto vm_error; + vm_error_kwargs_length_not_even: + SYNC_ALL (); + err_msg = scm_from_latin1_string ("Odd length of keyword argument list"); + scm_error_scm (sym_keyword_argument_error, program, err_msg, + SCM_EOL, SCM_BOOL_F); + + vm_error_kwargs_invalid_keyword: + /* FIXME say which one it was */ + SYNC_ALL (); + err_msg = scm_from_latin1_string ("Invalid keyword"); + scm_error_scm (sym_keyword_argument_error, program, err_msg, + SCM_EOL, SCM_BOOL_F); + + vm_error_kwargs_unrecognized_keyword: + /* FIXME say which one it was */ + SYNC_ALL (); + err_msg = scm_from_latin1_string ("Unrecognized keyword"); + scm_error_scm (sym_keyword_argument_error, program, err_msg, + SCM_EOL, SCM_BOOL_F); + vm_error_too_many_args: - err_msg = scm_from_locale_string ("VM: Too many arguments"); + err_msg = scm_from_latin1_string ("VM: Too many arguments"); finish_args = scm_list_1 (scm_from_int (nargs)); goto vm_error; @@ -176,59 +210,89 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) goto vm_error; vm_error_wrong_type_apply: - err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S " - "[IP offset: ~a]"); - finish_args = scm_list_2 (program, - SCM_I_MAKINUM (ip - bp->base)); + SYNC_ALL (); + scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S", + scm_list_1 (program), scm_list_1 (program)); goto vm_error; vm_error_stack_overflow: - err_msg = scm_from_locale_string ("VM: Stack overflow"); + err_msg = scm_from_latin1_string ("VM: Stack overflow"); finish_args = SCM_EOL; + if (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; goto vm_error; vm_error_stack_underflow: - err_msg = scm_from_locale_string ("VM: Stack underflow"); + err_msg = scm_from_latin1_string ("VM: Stack underflow"); finish_args = SCM_EOL; goto vm_error; vm_error_improper_list: - err_msg = scm_from_locale_string ("VM: Attempt to unroll an improper list: tail is ~A"); + err_msg = scm_from_latin1_string ("Expected a proper list, but got object with tail ~s"); goto vm_error; vm_error_not_a_pair: SYNC_ALL (); - scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "pair"); + scm_wrong_type_arg_msg (func_name, 1, finish_args, "pair"); + /* shouldn't get here */ + goto vm_error; + + vm_error_not_a_bytevector: + SYNC_ALL (); + scm_wrong_type_arg_msg (func_name, 1, finish_args, "bytevector"); + /* shouldn't get here */ + goto vm_error; + + vm_error_not_a_struct: + SYNC_ALL (); + scm_wrong_type_arg_msg (func_name, 1, finish_args, "struct"); + /* shouldn't get here */ + goto vm_error; + + vm_error_not_a_thunk: + SYNC_ALL (); + scm_wrong_type_arg_msg ("dynamic-wind", 1, finish_args, "thunk"); /* shouldn't get here */ goto vm_error; vm_error_no_values: - err_msg = scm_from_locale_string ("VM: 0-valued return"); + err_msg = scm_from_latin1_string ("Zero values returned to single-valued continuation"); finish_args = SCM_EOL; goto vm_error; vm_error_not_enough_values: - err_msg = scm_from_locale_string ("VM: Not enough values for mv-bind"); + err_msg = scm_from_latin1_string ("Too few values returned to continuation"); finish_args = SCM_EOL; goto vm_error; -#if VM_CHECK_IP + vm_error_continuation_not_rewindable: + err_msg = scm_from_latin1_string ("Unrewindable partial continuation"); + finish_args = scm_cons (finish_args, SCM_EOL); + goto vm_error; + + vm_error_bad_wide_string_length: + err_msg = scm_from_latin1_string ("VM: Bad wide string length: ~S"); + goto vm_error; + +#ifdef VM_CHECK_IP vm_error_invalid_address: - err_msg = scm_from_locale_string ("VM: Invalid program address"); + err_msg = scm_from_latin1_string ("VM: Invalid program address"); finish_args = SCM_EOL; goto vm_error; #endif -#if VM_CHECK_EXTERNAL - vm_error_external: - err_msg = scm_from_locale_string ("VM: Invalid external access"); +#if VM_CHECK_OBJECT + vm_error_object: + err_msg = scm_from_latin1_string ("VM: Invalid object table access"); finish_args = SCM_EOL; goto vm_error; #endif -#if VM_CHECK_OBJECT - vm_error_object: - err_msg = scm_from_locale_string ("VM: Invalid object table access"); +#if VM_CHECK_FREE_VARIABLES + vm_error_free_variable: + err_msg = scm_from_latin1_string ("VM: Invalid free variable access"); finish_args = SCM_EOL; goto vm_error; #endif @@ -244,10 +308,9 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) } #undef VM_USE_HOOKS -#undef VM_USE_CLOCK -#undef VM_CHECK_EXTERNAL #undef VM_CHECK_OBJECT -#undef VM_PUSH_DEBUG_FRAMES +#undef VM_CHECK_FREE_VARIABLE +#undef VM_CHECK_UNDERFLOW /* Local Variables: