mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00
Code Activity

in debug mode, make sure that calls to the vm can be captured via make-stack

Browse source 
* libguile/vm-engine.c (VM_PUSH_DEBUG_FRAMES): New knob, if true we much
  with the scm_i_last_debug_frame when entering the VM, because sometimes
  the evaluator doesn't do it for us.
  (VM_ENGINE): Plug through debug frame fondling. Now, program exit comes
  back to the main text. Rename err_args to finish_args, and reuse for
  the return value.

* libguile/vm-engine.h (PUSH_LIST):
* libguile/vm-i-loader.c:
* libguile/vm-i-scheme.c:
* libguile/vm-i-system.c: Update for finish_args.
  (halt): goto vm_done, now, instead of returning directly.
This commit is contained in:
Andy Wingo 2009-02-05 12:28:19 +01:00
parent 4abef68f61
commit e06e857c8d
5 changed files with 64 additions and 30 deletions
Download patch file Download diff file Expand all files Collapse all files

65
libguile/vm-engine.c
View file

@ -46,11 +46,13 @@
#define VM_USE_CLOCK 0 /* Bogoclock */ #define VM_USE_CLOCK 0 /* Bogoclock */
#define VM_CHECK_EXTERNAL 1 /* Check external link */ #define VM_CHECK_EXTERNAL 1 /* Check external link */
#define VM_CHECK_OBJECT 1 /* Check object table */ #define VM_CHECK_OBJECT 1 /* Check object table */
#define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
#define VM_USE_HOOKS 1 #define VM_USE_HOOKS 1
#define VM_USE_CLOCK 1 #define VM_USE_CLOCK 1
#define VM_CHECK_EXTERNAL 1 #define VM_CHECK_EXTERNAL 1
#define VM_CHECK_OBJECT 1 #define VM_CHECK_OBJECT 1
#define VM_PUSH_DEBUG_FRAMES 1
#else #else
#error unknown debug engine VM_ENGINE #error unknown debug engine VM_ENGINE
#endif #endif
@ -77,15 +79,23 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
/* Internal variables */ /* Internal variables */
int nvalues = 0; int nvalues = 0;
long start_time = scm_c_get_internal_run_time (); long start_time = scm_c_get_internal_run_time ();
SCM err_msg; SCM finish_args; /* used both for returns: both in error
SCM err_args; and normal situations */
#if VM_USE_HOOKS #if VM_USE_HOOKS
SCM hook_args = SCM_EOL; SCM hook_args = SCM_EOL;
#endif #endif
#ifdef HAVE_LABELS_AS_VALUES #ifdef HAVE_LABELS_AS_VALUES
static void **jump_table = NULL; 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;
#endif
#ifdef HAVE_LABELS_AS_VALUES
if (SCM_UNLIKELY (!jump_table)) if (SCM_UNLIKELY (!jump_table))
{ {
int i; int i;
@ -108,6 +118,19 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
/* Boot program */ /* Boot program */
program = vm_make_boot_program (nargs); program = vm_make_boot_program (nargs);
#if VM_PUSH_DEBUG_FRAMES
debug.prev = scm_i_last_debug_frame ();
if (!(debug.prev && debug.prev->status == SCM_APPLYFRAME
&& debug.prev->vect[0].a.proc != prog))
{
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 */ /* Initial frame */
CACHE_REGISTER (); CACHE_REGISTER ();
CACHE_PROGRAM (); CACHE_PROGRAM ();
@ -142,11 +165,22 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
} }
#endif #endif
vm_done:
SYNC_ALL ();
#if VM_PUSH_DEBUG_FRAMES
if (debug.status == SCM_APPLYFRAME)
scm_i_set_last_debug_frame (debug.prev);
#endif
return finish_args;
/* Errors */ /* Errors */
{ {
SCM err_msg;
vm_error_bad_instruction: vm_error_bad_instruction:
err_msg = scm_from_locale_string ("VM: Bad instruction: ~A"); err_msg = scm_from_locale_string ("VM: Bad instruction: ~A");
err_args = SCM_LIST1 (scm_from_uchar (ip[-1])); finish_args = SCM_LIST1 (scm_from_uchar (ip[-1]));
goto vm_error; goto vm_error;
vm_error_unbound: vm_error_unbound:
@ -155,12 +189,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
vm_error_wrong_type_arg: vm_error_wrong_type_arg:
err_msg = scm_from_locale_string ("VM: Wrong type argument"); err_msg = scm_from_locale_string ("VM: Wrong type argument");
err_args = SCM_EOL; finish_args = SCM_EOL;
goto vm_error; goto vm_error;
vm_error_too_many_args: vm_error_too_many_args:
err_msg = scm_from_locale_string ("VM: Too many arguments"); err_msg = scm_from_locale_string ("VM: Too many arguments");
err_args = SCM_LIST1 (scm_from_int (nargs)); finish_args = SCM_LIST1 (scm_from_int (nargs));
goto vm_error; goto vm_error;
vm_error_wrong_num_args: vm_error_wrong_num_args:
@ -173,18 +207,18 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
vm_error_wrong_type_apply: vm_error_wrong_type_apply:
err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S " err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S "
"[IP offset: ~a]"); "[IP offset: ~a]");
err_args = SCM_LIST2 (program, finish_args = SCM_LIST2 (program,
SCM_I_MAKINUM (ip - bp->base)); SCM_I_MAKINUM (ip - bp->base));
goto vm_error; goto vm_error;
vm_error_stack_overflow: vm_error_stack_overflow:
err_msg = scm_from_locale_string ("VM: Stack overflow"); err_msg = scm_from_locale_string ("VM: Stack overflow");
err_args = SCM_EOL; finish_args = SCM_EOL;
goto vm_error; goto vm_error;
vm_error_stack_underflow: vm_error_stack_underflow:
err_msg = scm_from_locale_string ("VM: Stack underflow"); err_msg = scm_from_locale_string ("VM: Stack underflow");
err_args = SCM_EOL; finish_args = SCM_EOL;
goto vm_error; goto vm_error;
vm_error_improper_list: vm_error_improper_list:
@ -193,18 +227,18 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
vm_error_not_a_pair: vm_error_not_a_pair:
SYNC_ALL (); SYNC_ALL ();
scm_wrong_type_arg_msg (FUNC_NAME, 1, err_args, "pair"); scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "pair");
/* shouldn't get here */ /* shouldn't get here */
goto vm_error; goto vm_error;
vm_error_no_values: vm_error_no_values:
err_msg = scm_from_locale_string ("VM: 0-valued return"); err_msg = scm_from_locale_string ("VM: 0-valued return");
err_args = SCM_EOL; finish_args = SCM_EOL;
goto vm_error; goto vm_error;
vm_error_not_enough_values: vm_error_not_enough_values:
err_msg = scm_from_locale_string ("VM: Not enough values for mv-bind"); err_msg = scm_from_locale_string ("VM: Not enough values for mv-bind");
err_args = SCM_EOL; finish_args = SCM_EOL;
goto vm_error; goto vm_error;
vm_error_no_such_module: vm_error_no_such_module:
@ -214,28 +248,28 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
#if VM_CHECK_IP #if VM_CHECK_IP
vm_error_invalid_address: vm_error_invalid_address:
err_msg = scm_from_locale_string ("VM: Invalid program address"); err_msg = scm_from_locale_string ("VM: Invalid program address");
err_args = SCM_EOL; finish_args = SCM_EOL;
goto vm_error; goto vm_error;
#endif #endif
#if VM_CHECK_EXTERNAL #if VM_CHECK_EXTERNAL
vm_error_external: vm_error_external:
err_msg = scm_from_locale_string ("VM: Invalid external access"); err_msg = scm_from_locale_string ("VM: Invalid external access");
err_args = SCM_EOL; finish_args = SCM_EOL;
goto vm_error; goto vm_error;
#endif #endif
#if VM_CHECK_OBJECT #if VM_CHECK_OBJECT
vm_error_object: vm_error_object:
err_msg = scm_from_locale_string ("VM: Invalid object table access"); err_msg = scm_from_locale_string ("VM: Invalid object table access");
err_args = SCM_EOL; finish_args = SCM_EOL;
goto vm_error; goto vm_error;
#endif #endif
vm_error: vm_error:
SYNC_ALL (); SYNC_ALL ();
scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, err_args), 1); scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, finish_args), 1);
} }
abort (); /* never reached */ abort (); /* never reached */
@ -245,6 +279,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
#undef VM_USE_CLOCK #undef VM_USE_CLOCK
#undef VM_CHECK_EXTERNAL #undef VM_CHECK_EXTERNAL
#undef VM_CHECK_OBJECT #undef VM_CHECK_OBJECT
#undef VM_PUSH_DEBUG_FRAMES
/* /*
Local Variables: Local Variables:

2
libguile/vm-engine.h
View file

@ -294,7 +294,7 @@ do \
for (; scm_is_pair (l); l = SCM_CDR (l)) \ for (; scm_is_pair (l); l = SCM_CDR (l)) \
PUSH (SCM_CAR (l)); \ PUSH (SCM_CAR (l)); \
if (SCM_UNLIKELY (!NILP (l))) { \ if (SCM_UNLIKELY (!NILP (l))) { \
err_args = scm_list_1 (l); \ finish_args = scm_list_1 (l); \
goto vm_error_improper_list; \ goto vm_error_improper_list; \
} \ } \
} while (0) } while (0)

2
libguile/vm-i-loader.c
View file

@ -122,7 +122,7 @@ VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1)
mod = scm_module_public_interface (mod); mod = scm_module_public_interface (mod);
if (SCM_FALSEP (mod)) if (SCM_FALSEP (mod))
{ {
err_args = SCM_LIST1 (SCM_CAR (what)); finish_args = SCM_LIST1 (SCM_CAR (what));
goto vm_error_no_such_module; goto vm_error_no_such_module;
} }
/* might longjmp */ /* might longjmp */

2
libguile/vm-i-scheme.c
View file

@ -136,7 +136,7 @@ VM_DEFINE_FUNCTION (90, cons, "cons", 2)
#define VM_VALIDATE_CONS(x) \ #define VM_VALIDATE_CONS(x) \
if (SCM_UNLIKELY (!scm_is_pair (x))) \ if (SCM_UNLIKELY (!scm_is_pair (x))) \
{ err_args = x; \ { finish_args = x; \
goto vm_error_not_a_pair; \ goto vm_error_not_a_pair; \
} }

23
libguile/vm-i-system.c
View file

@ -30,19 +30,18 @@ VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0) VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
{ {
SCM ret;
vp->time += scm_c_get_internal_run_time () - start_time; vp->time += scm_c_get_internal_run_time () - start_time;
HALT_HOOK (); HALT_HOOK ();
nvalues = SCM_I_INUM (*sp--); nvalues = SCM_I_INUM (*sp--);
NULLSTACK (1); NULLSTACK (1);
if (nvalues == 1) if (nvalues == 1)
POP (ret); POP (finish_args);
else else
{ {
POP_LIST (nvalues); POP_LIST (nvalues);
POP (ret); POP (finish_args);
SYNC_REGISTER (); SYNC_REGISTER ();
ret = scm_values (ret); finish_args = scm_values (finish_args);
} }
{ {
@ -55,8 +54,8 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
fp = SCM_FRAME_DYNAMIC_LINK (fp); fp = SCM_FRAME_DYNAMIC_LINK (fp);
NULLSTACK (stack_base - sp); NULLSTACK (stack_base - sp);
} }
SYNC_ALL ();
return ret; goto vm_done;
} }
VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0) VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0)
@ -254,8 +253,8 @@ VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
if (!VARIABLE_BOUNDP (x)) if (!VARIABLE_BOUNDP (x))
{ {
err_args = SCM_LIST1 (x); finish_args = SCM_LIST1 (x);
/* Was: err_args = SCM_LIST1 (SCM_CAR (x)); */ /* Was: finish_args = SCM_LIST1 (SCM_CAR (x)); */
goto vm_error_unbound; goto vm_error_unbound;
} }
else else
@ -299,7 +298,7 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
mod = scm_module_public_interface (mod); mod = scm_module_public_interface (mod);
if (SCM_FALSEP (mod)) if (SCM_FALSEP (mod))
{ {
err_args = SCM_LIST1 (mod); finish_args = SCM_LIST1 (mod);
goto vm_error_no_such_module; goto vm_error_no_such_module;
} }
/* might longjmp */ /* might longjmp */
@ -308,7 +307,7 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
if (!VARIABLE_BOUNDP (what)) if (!VARIABLE_BOUNDP (what))
{ {
err_args = SCM_LIST1 (what); finish_args = SCM_LIST1 (what);
goto vm_error_unbound; goto vm_error_unbound;
} }
@ -382,7 +381,7 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
mod = scm_module_public_interface (mod); mod = scm_module_public_interface (mod);
if (SCM_FALSEP (mod)) if (SCM_FALSEP (mod))
{ {
err_args = SCM_LIST1 (what); finish_args = SCM_LIST1 (what);
goto vm_error_no_such_module; goto vm_error_no_such_module;
} }
/* might longjmp */ /* might longjmp */
@ -1088,7 +1087,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
nvalues++; nvalues++;
} }
if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) { if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
err_args = scm_list_1 (l); finish_args = scm_list_1 (l);
goto vm_error_improper_list; goto vm_error_improper_list;
} }