rework vm tracing

* libguile/vm-engine.c (VM_NAME): Engines take the VM itself (not the
  vp), so they can pass the VM to hooks. No more hook args, we dispatch
  without them.

* libguile/vm-engine.h (RUN_HOOK): Dispatch the hook if the trace level
  is positive (instead of if the hook is there). Don't cache registers
  on return from the dispatch.

* libguile/vm.h:
* libguile/vm.c (vm_dispatch_hook): Don't bother with a dynwind; instead
  decrement the trace level when going into a hook, and if we have a
  nonlocal exit, the trace level never gets incremented again. Worse is
  better.
  (make_vm, scm_vm_trace_level, scm_set_vm_trace_level_x): New concept,
  trace level. If positive, we run the hooks, otherwise we don't. Should
  work. Removed scm_vm_trace_frame, I don't think that was the right way
  to do it.

* module/system/vm/vm.scm: Replace vm-trace-frame with vm-trace-level
  and set-vm-trace-level!; the hooks actually get the frame as an
  argument now.

libguile/vm-engine.c

@@ -34,12 +34,13 @@
 
 
 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 */
@@ -53,10 +54,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
   int nvalues = 0;
   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

libguile/vm-engine.h

@@ -208,11 +208,10 @@
 #if VM_USE_HOOKS
 #define RUN_HOOK(h)                                     \
   {                                                     \
-  if (SCM_UNLIKELY (scm_is_true (vp->hooks[h])))\
+    if (SCM_UNLIKELY (vp->trace_level > 0))             \
       {                                                 \
         SYNC_REGISTER ();				\
-      vm_dispatch_hook (vp, vp->hooks[h], hook_args);      \
+        vm_dispatch_hook (vm, h);                       \
-      CACHE_REGISTER ();			\
       }                                                 \
   }
 #else

libguile/vm.c

@@ -144,26 +144,24 @@ scm_vm_reinstate_continuations (SCM conts)
     reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts));
 }
 
-static void enfalsen_frame (void *p)
-{ 
-  struct scm_vm *vp = p;
-  vp->trace_frame = SCM_BOOL_F;
-}
-
 static void
-vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args)
+vm_dispatch_hook (SCM vm, int hook_num)
 {
-  if (!scm_is_false (vp->trace_frame))
+  struct scm_vm *vp;
+  SCM hook;
+  SCM frame;
+
+  vp = SCM_VM_DATA (vm);
+  hook = vp->hooks[hook_num];
+
+  if (SCM_LIKELY (scm_is_false (hook))
+      || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
     return;
   
-  scm_dynwind_begin (0);
+  vp->trace_level--;
-  /* FIXME, stack holder should be the vm */
+  frame = scm_c_make_frame (vm, vp->fp, vp->sp, vp->ip, 0);
-  vp->trace_frame = scm_c_make_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
+  scm_c_run_hookn (hook, &frame, 1);
-  scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
+  vp->trace_level++;
-
-  scm_c_run_hook (hook, hook_args);
-
-  scm_dynwind_end ();
 }
 
 
@@ -363,9 +361,9 @@ make_vm (void)
   vp->fp    	  = NULL;
   vp->engine      = SCM_VM_DEBUG_ENGINE;
   vp->options     = SCM_EOL;
+  vp->trace_level = 0;
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
     vp->hooks[i] = SCM_BOOL_F;
-  vp->trace_frame = SCM_BOOL_F;
   SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
 }
 #undef FUNC_NAME
@@ -406,7 +404,7 @@ SCM
 scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 {
   struct scm_vm *vp = SCM_VM_DATA (vm);
-  return vm_engines[vp->engine](vp, program, argv, nargs);
+  return vm_engines[vp->engine](vm, program, argv, nargs);
 }
 
 SCM
@@ -618,13 +616,24 @@ SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
+SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
 	    (SCM vm),
 	    "")
-#define FUNC_NAME s_scm_vm_trace_frame
+#define FUNC_NAME s_scm_vm_trace_level
 {
   SCM_VALIDATE_VM (1, vm);
-  return SCM_VM_DATA (vm)->trace_frame;
+  return scm_from_int (SCM_VM_DATA (vm)->trace_level);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
+	    (SCM vm, SCM level),
+	    "")
+#define FUNC_NAME s_scm_set_vm_trace_level_x
+{
+  SCM_VALIDATE_VM (1, vm);
+  SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
+  return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
 

libguile/vm.h

@@ -34,7 +34,7 @@
 
 struct scm_vm;
 
-typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, SCM program, SCM *argv, int nargs);
+typedef SCM (*scm_t_vm_engine) (SCM vm, SCM program, SCM *argv, int nargs);
 
 #define SCM_VM_REGULAR_ENGINE 0
 #define SCM_VM_DEBUG_ENGINE 1
@@ -50,7 +50,7 @@ struct scm_vm {
   int engine;                   /* which vm engine we're using */
   SCM hooks[SCM_VM_NUM_HOOKS];	/* hooks */
   SCM options;			/* options */
-  SCM trace_frame;              /* a frame being traced */
+  int trace_level;              /* traces enabled if trace_level > 0 */
 };
 
 SCM_API SCM scm_the_vm_fluid;
@@ -83,7 +83,8 @@ SCM_API SCM scm_vm_exit_hook (SCM vm);
 SCM_API SCM scm_vm_return_hook (SCM vm);
 SCM_API SCM scm_vm_option (SCM vm, SCM key);
 SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
-SCM_API SCM scm_vm_trace_frame (SCM vm);
+SCM_API SCM scm_vm_trace_level (SCM vm);
+SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
 
 struct scm_vm_cont {
   scm_t_uint8 *ip;

module/system/vm/vm.scm

@@ -27,7 +27,7 @@
             vm-load vm-option set-vm-option! vm-version
             vms:time vms:clock
 
-            vm-trace-frame
+            vm-trace-level set-vm-trace-level!
             vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
             vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))