trim our set of vm hooks

* libguile/vm.h (SCM_VM_PUSH_CONTINUATION_HOOK)
  (SCM_VM_POP_CONTINUATION_HOOK): New hooks, to replace
  enter/exit/return.
  (SCM_VM_BOOT_HOOK, SCM_VM_HALT_HOOK, SCM_VM_BREAK_HOOK): Remove these
  useless hooks.

* libguile/vm.c (scm_vm_push_continuation_hook)
  (scm_vm_pop_continuation_hook): New accessors.

* libguile/vm-i-system.c: Remove boot, halt, break, enter, exit, and
  return hooks. Also remove the break instruction. Instead now when we
  push a new continuation onto the stack we call PUSH_CONTINUATION_HOOK,
  and when we pop via a return we call POP_CONTINUATION_HOOK. APPLY_HOOK
  is now decoupled from continuation pushes and pops.

* libguile/vm-engine.h:
* libguile/vm-engine.c: Adapt for hooks.

* module/system/vm/trace.scm (vm-trace): Adapt for hooks. Also revive
  the #:instructions? #t mode.

* module/system/vm/vm.scm: Adapt exports for new set of hooks.

libguile/vm-engine.c

@@ -104,7 +104,6 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
   }
 
   /* Let's go! */
-  BOOT_HOOK ();
   NEXT;
 
 #ifndef HAVE_LABELS_AS_VALUES

libguile/vm-engine.h

@@ -224,14 +224,14 @@
 #define RUN_HOOK1(h, x)
 #endif
 
-#define BOOT_HOOK()	RUN_HOOK (SCM_VM_BOOT_HOOK)
+#define APPLY_HOOK()                            \
-#define HALT_HOOK()	RUN_HOOK (SCM_VM_HALT_HOOK)
+  RUN_HOOK (SCM_VM_APPLY_HOOK)
-#define NEXT_HOOK()	RUN_HOOK (SCM_VM_NEXT_HOOK)
+#define PUSH_CONTINUATION_HOOK()                \
-#define BREAK_HOOK()	RUN_HOOK (SCM_VM_BREAK_HOOK)
+  RUN_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK)
-#define ENTER_HOOK()	RUN_HOOK (SCM_VM_ENTER_HOOK)
+#define POP_CONTINUATION_HOOK(n)                \
-#define APPLY_HOOK()	RUN_HOOK (SCM_VM_APPLY_HOOK)
+  RUN_HOOK1 (SCM_VM_POP_CONTINUATION_HOOK, SCM_I_MAKINUM (n))
-#define EXIT_HOOK()	RUN_HOOK (SCM_VM_EXIT_HOOK)
+#define NEXT_HOOK()                             \
-#define RETURN_HOOK(n)	RUN_HOOK1 (SCM_VM_RETURN_HOOK, SCM_I_MAKINUM (n))
+  RUN_HOOK (SCM_VM_NEXT_HOOK)
 
 #define VM_HANDLE_INTERRUPTS                     \
   SCM_ASYNC_TICK_WITH_CODE (SYNC_REGISTER ())

libguile/vm-i-system.c

@@ -31,7 +31,6 @@ VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
 
 VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
 {
-  HALT_HOOK ();
   nvalues = SCM_I_INUM (*sp--);
   NULLSTACK (1);
   if (nvalues == 1)
@@ -62,12 +61,6 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
   goto vm_done;
 }
 
-VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0)
-{
-  BREAK_HOOK ();
-  NEXT;
-}
-
 VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
 {
   DROP ();
@@ -779,7 +772,7 @@ VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
   SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
   SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
   ip = SCM_C_OBJCODE_BASE (bp);
-  ENTER_HOOK ();
+  PUSH_CONTINUATION_HOOK ();
   APPLY_HOOK ();
   NEXT;
 }
@@ -818,8 +811,6 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
       CHECK_STACK_LEAK ();
 #endif
 
-      EXIT_HOOK ();
-
       /* switch programs */
       CACHE_PROGRAM ();
       /* shuffle down the program and the arguments */
@@ -832,7 +823,6 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
 
       ip = SCM_C_OBJCODE_BASE (bp);
 
-      ENTER_HOOK ();
       APPLY_HOOK ();
       NEXT;
     }
@@ -1083,7 +1073,7 @@ VM_DEFINE_INSTRUCTION (61, mv_call, "mv-call", 4, -1, 1)
   SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
   SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
   ip = SCM_C_OBJCODE_BASE (bp);
-  ENTER_HOOK ();
+  PUSH_CONTINUATION_HOOK ();
   APPLY_HOOK ();
   NEXT;
 }
@@ -1198,8 +1188,7 @@ VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc", 0, 1, 1)
 VM_DEFINE_INSTRUCTION (66, return, "return", 0, 1, 1)
 {
  vm_return:
-  EXIT_HOOK ();
+  POP_CONTINUATION_HOOK (1);
-  RETURN_HOOK (1);
 
   VM_HANDLE_INTERRUPTS;
 
@@ -1238,8 +1227,7 @@ VM_DEFINE_INSTRUCTION (67, return_values, "return/values", 1, -1, -1)
      that perhaps it might be used without declaration. Fooey to that, I say. */
   nvalues = FETCH ();
  vm_return_values:
-  EXIT_HOOK ();
+  POP_CONTINUATION_HOOK (nvalues);
-  RETURN_HOOK (nvalues);
 
   VM_HANDLE_INTERRUPTS;
 

libguile/vm.c

@@ -668,51 +668,6 @@ SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
   return vp->hooks[n];					\
 }
 
-SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
-	    (SCM vm),
-	    "")
-#define FUNC_NAME s_scm_vm_boot_hook
-{
-  VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
-	    (SCM vm),
-	    "")
-#define FUNC_NAME s_scm_vm_halt_hook
-{
-  VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
-	    (SCM vm),
-	    "")
-#define FUNC_NAME s_scm_vm_next_hook
-{
-  VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
-	    (SCM vm),
-	    "")
-#define FUNC_NAME s_scm_vm_break_hook
-{
-  VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
-	    (SCM vm),
-	    "")
-#define FUNC_NAME s_scm_vm_enter_hook
-{
-  VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 	    (SCM vm),
 	    "")
@@ -722,21 +677,30 @@ SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0,
 	    (SCM vm),
 	    "")
-#define FUNC_NAME s_scm_vm_exit_hook
+#define FUNC_NAME s_scm_vm_push_continuation_hook
 {
-  VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
+  VM_DEFINE_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK);
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
 	    (SCM vm),
 	    "")
-#define FUNC_NAME s_scm_vm_return_hook
+#define FUNC_NAME s_scm_vm_pop_continuation_hook
 {
-  VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
+  VM_DEFINE_HOOK (SCM_VM_POP_CONTINUATION_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_next_hook
+{
+  VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 }
 #undef FUNC_NAME
 

libguile/vm.h

@@ -22,15 +22,13 @@
 #include <libguile.h>
 #include <libguile/programs.h>
 
-#define SCM_VM_BOOT_HOOK	0
+enum {
-#define SCM_VM_HALT_HOOK	1
+  SCM_VM_APPLY_HOOK,
-#define SCM_VM_NEXT_HOOK	2
+  SCM_VM_PUSH_CONTINUATION_HOOK,
-#define SCM_VM_BREAK_HOOK	3
+  SCM_VM_POP_CONTINUATION_HOOK,
-#define SCM_VM_ENTER_HOOK	4
+  SCM_VM_NEXT_HOOK,
-#define SCM_VM_APPLY_HOOK	5
+  SCM_VM_NUM_HOOKS,
-#define SCM_VM_EXIT_HOOK	6
+};
-#define SCM_VM_RETURN_HOOK	7
-#define SCM_VM_NUM_HOOKS	8
 
 struct scm_vm;
 
@@ -73,14 +71,10 @@ SCM_API SCM scm_vm_p (SCM obj);
 SCM_API SCM scm_vm_ip (SCM vm);
 SCM_API SCM scm_vm_sp (SCM vm);
 SCM_API SCM scm_vm_fp (SCM vm);
-SCM_API SCM scm_vm_boot_hook (SCM vm);
-SCM_API SCM scm_vm_halt_hook (SCM vm);
-SCM_API SCM scm_vm_next_hook (SCM vm);
-SCM_API SCM scm_vm_break_hook (SCM vm);
-SCM_API SCM scm_vm_enter_hook (SCM vm);
 SCM_API SCM scm_vm_apply_hook (SCM vm);
-SCM_API SCM scm_vm_exit_hook (SCM vm);
+SCM_API SCM scm_vm_push_continuation_hook (SCM vm);
-SCM_API SCM scm_vm_return_hook (SCM vm);
+SCM_API SCM scm_vm_pop_continuation_hook (SCM vm);
+SCM_API SCM scm_vm_next_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_level (SCM vm);

module/system/vm/trace.scm

@@ -22,53 +22,39 @@
   #:use-module (system base syntax)
   #:use-module (system vm vm)
   #:use-module (system vm frame)
+  #:use-module (system vm program)
+  #:use-module (system vm objcode)
+  #:use-module (rnrs bytevectors)
+  #:use-module (system vm instruction)
   #:use-module (ice-9 format)
   #:export (vm-trace))
 
+;; FIXME: this constant needs to go in system vm objcode
+(define *objcode-header-len* 8)
+
 (define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
   (define *call-depth* #f)
   (define *saved-call-depth* #f)
 
-  (define (trace-enter frame)
+  (define (print-application frame depth)
-    (cond
-     (*call-depth*
-      (set! *call-depth* (1+ *call-depth*)))))
-
-  (define (trace-exit frame)
-    (cond
-     ((not *call-depth*))
-     (else
-      (set! *call-depth* (1- *call-depth*)))))
-  
-  (define (trace-apply frame)
-    (cond
-     (*call-depth*
     (format (current-error-port) "~a~v:@y\n"
-              (make-string (1- *call-depth*) #\|)
+            (make-string depth #\|)
-              (max (- width *call-depth* 1) 1)
+            (max (- width depth) 1)
             (frame-call-representation frame)))
-     ((eq? (frame-procedure frame) thunk)
-      (set! *call-depth* 1))))
 
-  (define (trace-return frame)
+  (define (print-return frame depth)
-    ;; nop, though we could print the return i guess
-    (cond
-     ((and *call-depth* (< *call-depth* 0))
-      ;; leaving the thunk
-      (set! *call-depth* #f))
-     (*call-depth*
     (let* ((len (frame-num-locals frame))
            (nvalues (frame-local-ref frame (1- len))))
       (cond
        ((= nvalues 1)
         (format (current-error-port) "~a~v:@y\n"
-                  (make-string *call-depth* #\|)
+                (make-string depth #\|)
                 width (frame-local-ref frame (- len 2))))
        (else
         ;; this should work, but there appears to be a bug
         ;; "~a~d values:~:{ ~v:@y~}\n"
         (format (current-error-port) "~a~d values:~{ ~a~}\n"
-                  (make-string *call-depth* #\|)
+                (make-string depth #\|)
                 nvalues
                 (let lp ((vals '()) (i 0))
                   (if (= i nvalues)
@@ -76,27 +62,46 @@
                       (lp (cons (format #f "~v:@y" width
                                         (frame-local-ref frame (- len 2 i)))
                                 vals)
-                            (1+ i)))))))))))
+                          (1+ i)))))))))
+
+  (define (trace-push frame)
+    (if *call-depth*
+        (set! *call-depth* (1+ *call-depth*))))
+
+  (define (trace-pop frame)
+    (if *call-depth*
+        (begin
+          (print-return frame *call-depth*)
+          (set! *call-depth*
+                (if (zero? *call-depth*)
+                    #f
+                    (1- *call-depth*))))))
+  
+  (define (trace-apply frame)
+    (cond
+     (*call-depth*
+      (print-application frame *call-depth*))
+     ((eq? (frame-procedure frame) thunk)
+      (set! *call-depth* 0))))
 
   (define (trace-next frame)
-    (format #t "0x~8X" (frame-instruction-pointer frame))
+    (let* ((ip (frame-instruction-pointer frame))
-    ;; should disassemble the thingy; could print stack, or stack trace,
+           (objcode (program-objcode (frame-procedure frame)))
-    ;; ...
+           (opcode (bytevector-u8-ref (objcode->bytecode objcode)
-    )
+                                      (+ ip *objcode-header-len*)))
+           (inst (opcode->instruction opcode)))
+      (format #t "0x~8X: ~a: ~a\n" ip opcode inst)))
   
   (define (vm-trace-on!)
     (if calls?
         (begin
-          (add-hook! (vm-exit-hook vm) trace-exit)
+          (add-hook! (vm-push-continuation-hook vm) trace-push)
-          (add-hook! (vm-enter-hook vm) trace-enter)
+          (add-hook! (vm-pop-continuation-hook vm) trace-pop)
-          (add-hook! (vm-apply-hook vm) trace-apply)
+          (add-hook! (vm-apply-hook vm) trace-apply)))
-          (add-hook! (vm-return-hook vm) trace-return)))
 
     (if instructions?
         (add-hook! (vm-next-hook vm) trace-next))
 
-    ;; boot, halt, and break are the other ones
-
     (set-vm-trace-level! vm (1+ (vm-trace-level vm)))
     (set! *call-depth* *saved-call-depth*))
   
@@ -107,10 +112,9 @@
 
     (if calls?
         (begin
-          (remove-hook! (vm-exit-hook vm) trace-exit)
+          (remove-hook! (vm-push-continuation-hook vm) trace-push)
-          (remove-hook! (vm-enter-hook vm) trace-enter)
+          (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
-          (remove-hook! (vm-apply-hook vm) trace-apply)
+          (remove-hook! (vm-apply-hook vm) trace-apply)))
-          (remove-hook! (vm-return-hook vm) trace-return)))
     
     (if instructions?
         (remove-hook! (vm-next-hook vm) trace-next)))

module/system/vm/vm.scm

@@ -28,8 +28,9 @@
             vms:time vms:clock
 
             vm-trace-level set-vm-trace-level!
-            vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
+            vm-push-continuation-hook vm-pop-continuation-hook
-            vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
+            vm-apply-hook
+            vm-next-hook))
 
 (load-extension (string-append "libguile-" (effective-version))
                 "scm_init_vm")