X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/5f236208d0d864546e59afa0f5a11c9b3ba14b10..81b80b9610798ea910daad78cf525dec211639f9:/libguile/vm-engine.c diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index b373cd017..c90458df6 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009 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 @@ -20,16 +20,14 @@ #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE) #define VM_USE_HOOKS 0 /* Various hooks */ -#define VM_USE_CLOCK 0 /* Bogoclock */ -#define VM_CHECK_OBJECT 1 /* Check object table */ -#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */ -#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_OBJECT 1 -#define VM_CHECK_FREE_VARIABLES 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 @@ -38,55 +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_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 *free_vars = NULL; /* free variables */ - size_t free_vars_count = 0; /* length of FREE_VARS */ 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 */ @@ -96,28 +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)fp); /* dynamic link */ - PUSH (0); /* ra */ - PUSH (0); /* mvra */ + PUSH (SCM_PACK (fp)); /* dynamic link */ + PUSH (SCM_PACK (0)); /* mvra */ + PUSH (SCM_PACK (ip)); /* ra */ CACHE_PROGRAM (); PUSH (program); fp = sp + 1; - INIT_FRAME (); + ip = SCM_C_OBJCODE_BASE (bp); /* MV-call frame, function & arguments */ - PUSH ((SCM)fp); /* dynamic link */ - PUSH (0); /* ra */ - PUSH (0); /* mvra */ + 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; @@ -126,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 @@ -148,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: ~s"); + 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: ~s"); + /* 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; @@ -185,67 +211,88 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) vm_error_wrong_type_apply: SYNC_ALL (); - scm_error (scm_misc_error_key, FUNC_NAME, "Wrong type to apply: ~S", - scm_list_1 (program), SCM_BOOL_F); + 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 ("Expected a proper list, but got object with tail ~s"); + 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"); + 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 ("Zero values returned to single-valued continuation"); + 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 ("Too few values returned to continuation"); + err_msg = scm_from_latin1_string ("Too few values returned to continuation"); finish_args = SCM_EOL; goto vm_error; + 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_locale_string ("VM: Bad wide string length: ~S"); + err_msg = scm_from_latin1_string ("VM: Bad wide string length: ~S"); goto vm_error; -#if VM_CHECK_IP +#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_OBJECT vm_error_object: - err_msg = scm_from_locale_string ("VM: Invalid object table access"); + err_msg = scm_from_latin1_string ("VM: Invalid object table access"); finish_args = SCM_EOL; goto vm_error; #endif #if VM_CHECK_FREE_VARIABLES vm_error_free_variable: - err_msg = scm_from_locale_string ("VM: Invalid free variable access"); + err_msg = scm_from_latin1_string ("VM: Invalid free variable access"); finish_args = SCM_EOL; goto vm_error; #endif @@ -261,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_OBJECT #undef VM_CHECK_FREE_VARIABLE -#undef VM_PUSH_DEBUG_FRAMES +#undef VM_CHECK_UNDERFLOW /* Local Variables: