summaryrefslogtreecommitdiff
path: root/libguile/vm-engine.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-05 12:28:19 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-05 12:28:19 +0100
commite06e857c8dc1f9f8c25bc4d3e40ce5bf351753d5 (patch)
treea284b9ba2bad1c16709a49e3f25058f552df7b79 /libguile/vm-engine.c
parent4abef68f61f3ff4e674734a4aae18514dd96f221 (diff)
downloadguile-e06e857c8dc1f9f8c25bc4d3e40ce5bf351753d5.tar.gz
in debug mode, make sure that calls to the vm can be captured via make-stack
* 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.
Diffstat (limited to 'libguile/vm-engine.c')
-rw-r--r--libguile/vm-engine.c65
1 files changed, 50 insertions, 15 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 84f39fe49..4d459a9a1 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -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: