mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +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_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 */
#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
#else
#error unknown debug engine VM_ENGINE
#endif
@ -77,15 +79,23 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
/* Internal variables */
int nvalues = 0;
long start_time = scm_c_get_internal_run_time ();
SCM err_msg;
SCM err_args;
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;
#endif
#ifdef HAVE_LABELS_AS_VALUES
if (SCM_UNLIKELY (!jump_table))
{
int i;
@ -108,6 +118,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 ();
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 */
CACHE_REGISTER ();
CACHE_PROGRAM ();
@ -142,11 +165,22 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
}
#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 */
{
SCM err_msg;
vm_error_bad_instruction:
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;
vm_error_unbound:
@ -155,12 +189,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
vm_error_wrong_type_arg:
err_msg = scm_from_locale_string ("VM: Wrong type argument");
err_args = SCM_EOL;
finish_args = SCM_EOL;
goto vm_error;
vm_error_too_many_args:
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;
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:
err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S "
"[IP offset: ~a]");
err_args = SCM_LIST2 (program,
finish_args = SCM_LIST2 (program,
SCM_I_MAKINUM (ip - bp->base));
goto vm_error;
vm_error_stack_overflow:
err_msg = scm_from_locale_string ("VM: Stack overflow");
err_args = SCM_EOL;
finish_args = SCM_EOL;
goto vm_error;
vm_error_stack_underflow:
err_msg = scm_from_locale_string ("VM: Stack underflow");
err_args = SCM_EOL;
finish_args = SCM_EOL;
goto vm_error;
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:
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 */
goto vm_error;
vm_error_no_values:
err_msg = scm_from_locale_string ("VM: 0-valued return");
err_args = SCM_EOL;
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_args = SCM_EOL;
finish_args = SCM_EOL;
goto vm_error;
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
vm_error_invalid_address:
err_msg = scm_from_locale_string ("VM: Invalid program address");
err_args = SCM_EOL;
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");
err_args = SCM_EOL;
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_args = SCM_EOL;
finish_args = SCM_EOL;
goto vm_error;
#endif
vm_error:
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 */
@ -245,6 +279,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
#undef VM_USE_CLOCK
#undef VM_CHECK_EXTERNAL
#undef VM_CHECK_OBJECT
#undef VM_PUSH_DEBUG_FRAMES
/*
Local Variables: