mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 04:40:29 +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:

2
libguile/vm-engine.h
View file

@ -294,7 +294,7 @@ do \
for (; scm_is_pair (l); l = SCM_CDR (l)) \
PUSH (SCM_CAR (l)); \
if (SCM_UNLIKELY (!NILP (l))) { \
err_args = scm_list_1 (l); \
finish_args = scm_list_1 (l); \
goto vm_error_improper_list; \
} \
} 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);
if (SCM_FALSEP (mod))
{
err_args = SCM_LIST1 (SCM_CAR (what));
finish_args = SCM_LIST1 (SCM_CAR (what));
goto vm_error_no_such_module;
}
/* 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) \
if (SCM_UNLIKELY (!scm_is_pair (x))) \
{ err_args = x; \
{ finish_args = x; \
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)
{
SCM ret;
vp->time += scm_c_get_internal_run_time () - start_time;
HALT_HOOK ();
nvalues = SCM_I_INUM (*sp--);
NULLSTACK (1);
if (nvalues == 1)
POP (ret);
POP (finish_args);
else
{
POP_LIST (nvalues);
POP (ret);
POP (finish_args);
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);
NULLSTACK (stack_base - sp);
}
SYNC_ALL ();
return ret;
goto vm_done;
}
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))
{
err_args = SCM_LIST1 (x);
/* Was: err_args = SCM_LIST1 (SCM_CAR (x)); */
finish_args = SCM_LIST1 (x);
/* Was: finish_args = SCM_LIST1 (SCM_CAR (x)); */
goto vm_error_unbound;
}
else
@ -299,7 +298,7 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
mod = scm_module_public_interface (mod);
if (SCM_FALSEP (mod))
{
err_args = SCM_LIST1 (mod);
finish_args = SCM_LIST1 (mod);
goto vm_error_no_such_module;
}
/* might longjmp */
@ -308,7 +307,7 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
if (!VARIABLE_BOUNDP (what))
{
err_args = SCM_LIST1 (what);
finish_args = SCM_LIST1 (what);
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);
if (SCM_FALSEP (mod))
{
err_args = SCM_LIST1 (what);
finish_args = SCM_LIST1 (what);
goto vm_error_no_such_module;
}
/* might longjmp */
@ -1088,7 +1087,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
nvalues++;
}
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;
}