tracing in terms of traps

* module/system/vm/traps.scm (trap-frame-finish)
  (trap-in-dynamic-extent, trap-calls-in-dynamic-extent)
  (trap-instructions-in-dynamic-extent): New traps, for implementing
  tracing, and the `finish' command.

* module/system/vm/trace.scm (trace-calls-in-procedure)
  (trace-instructions-in-procedure): New tracing traps.
  (vm-trace): Reimplement in terms of the new traps.

* module/system/vm/trap-state.scm (add-trap!): New helper; not used in
  this commit, though.

module/system/vm/trace.scm

@@ -24,18 +24,25 @@
   #:use-module (system vm frame)
   #:use-module (system vm program)
   #:use-module (system vm objcode)
+  #:use-module (system vm traps)
   #:use-module (rnrs bytevectors)
   #:use-module (system vm instruction)
   #:use-module (ice-9 format)
-  #:export (vm-trace))
+  #:export (trace-calls-in-procedure
+            trace-instructions-in-procedure
+            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-calls-in-procedure proc #:key (width 80) (vm (the-vm)))
+  (define (frame-return-values frame)
+    (let* ((len (frame-num-locals frame))
+           (nvalues (frame-local-ref frame (1- len))))
+      (map (lambda (i)
+             (frame-local-ref frame (+ (- len nvalues) i)))
+           (iota nvalues))))
+  
   (define (print-application frame depth)
     (format (current-error-port) "~a~v:@y\n"
             (make-string depth #\|)
@@ -56,70 +63,50 @@
         (format (current-error-port) "~a~d values:~{ ~a~}\n"
                 (make-string depth #\|)
                 nvalues
-                (let lp ((vals '()) (i 0))
-                  (if (= i nvalues)
-                      vals
-                      (lp (cons (format #f "~v:@y" width
-                                        (frame-local-ref frame (- len 2 i)))
-                                vals)
-                          (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*))))))
+                (map (lambda (val)
+                       (format #f "~v:@y" width val))
+                     (frame-return-values frame)))))))
   
-  (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)
-    (if *call-depth*
-        (let* ((ip (frame-instruction-pointer frame))
-               (objcode (program-objcode (frame-procedure frame)))
-               (opcode (bytevector-u8-ref (objcode->bytecode objcode)
-                                          (+ ip *objcode-header-len*))))
-          (format #t "~8d: ~a\n" ip (opcode->instruction opcode)))))
+    (let* ((ip (frame-instruction-pointer frame))
+           (objcode (program-objcode (frame-procedure frame)))
+           (opcode (bytevector-u8-ref (objcode->bytecode objcode)
+                                      (+ ip *objcode-header-len*))))
+      (format #t "~8d: ~a\n" ip (opcode->instruction opcode))))
   
-  (define (vm-trace-on!)
-    (if calls?
-        (begin
-          (add-hook! (vm-push-continuation-hook vm) trace-push)
-          (add-hook! (vm-pop-continuation-hook vm) trace-pop)
-          (add-hook! (vm-apply-hook vm) trace-apply)))
+  (trap-calls-in-dynamic-extent proc print-application print-return
+                                #:vm vm))
 
-    (if instructions?
-        (add-hook! (vm-next-hook vm) trace-next))
-
-    (set-vm-trace-level! vm (1+ (vm-trace-level vm)))
-    (set! *call-depth* *saved-call-depth*))
+(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm)))
+  (define (trace-next frame)
+    (let* ((ip (frame-instruction-pointer frame))
+           (objcode (program-objcode (frame-procedure frame)))
+           (opcode (bytevector-u8-ref (objcode->bytecode objcode)
+                                      (+ ip *objcode-header-len*))))
+      (format #t "~8d: ~a\n" ip (opcode->instruction opcode))))
   
-  (define (vm-trace-off!)
-    (set! *saved-call-depth* *call-depth*)
-    (set! *call-depth* #f)
-    (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+  (trap-instructions-in-dynamic-extent proc trace-next
+                                       #:vm vm))
 
-    (if calls?
-        (begin
-          (remove-hook! (vm-push-continuation-hook vm) trace-push)
-          (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
-          (remove-hook! (vm-apply-hook vm) trace-apply)))
-    
-    (if instructions?
-        (remove-hook! (vm-next-hook vm) trace-next)))
-
-  (dynamic-wind
-    vm-trace-on!
-    (lambda () (vm-apply vm thunk '()))
-    vm-trace-off!))
+;; Note that because this procedure manipulates the VM trace level
+;; directly, it doesn't compose well with traps at the REPL.
+;;
+(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
+  (let ((call-trap #f)
+        (inst-trap #f))
+    (dynamic-wind
+      (lambda ()
+        (if calls?
+            (set! call-trap
+                  (trace-calls-in-procedure thunk #:vm vm #:width width)))
+        (if instructions?
+            (set! inst-trap
+                  (trace-instructions-in-procedure thunk #:vm vm #:width width)))
+        (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
+      thunk
+      (lambda ()
+        (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+        (if call-trap (call-trap))
+        (if inst-trap (inst-trap))
+        (set! call-trap #f)
+        (set! inst-trap #f)))))

module/system/vm/trap-state.scm

@@ -188,3 +188,9 @@
      (make-trap-wrapper
       idx #t trap
       (format #f "breakpoint at ~a" proc)))))
+
+(define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
+  (let* ((idx (next-index! trap-state)))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper idx #t trap name))))

module/system/vm/traps.scm

@@ -66,7 +66,11 @@
             trap-in-procedure
             trap-instructions-in-procedure
             trap-at-procedure-ip-in-range
-            trap-at-source-location))
+            trap-at-source-location
+            trap-frame-finish
+            trap-in-dynamic-extent
+            trap-calls-in-dynamic-extent
+            trap-instructions-in-dynamic-extent))
 
 (define-syntax arg-check
   (syntax-rules ()
@@ -334,3 +338,145 @@
      (lambda (frame)
        (for-each (lambda (trap) (trap frame)) traps)
        (set! traps #f)))))
+
+
+
+;; On a different tack, now we're going to build up a set of traps that
+;; do useful things during the dynamic extent of a procedure's
+;; application. First, a trap for when a frame returns.
+;;
+(define* (trap-frame-finish frame return-handler abort-handler
+                            #:key (vm (the-vm)))
+  (arg-check frame frame?)
+  (arg-check return-handler procedure?)
+  (arg-check abort-handler procedure?)
+  (let ((fp (frame-dynamic-link frame)))
+    (define (pop-cont-hook frame)
+      (if (and fp (eq? (frame-dynamic-link frame) fp))
+          (begin
+            (set! fp #f)
+            (return-handler frame))))
+    
+    (define (abort-hook frame)
+      (if (and fp (<= (frame-dynamic-link frame) fp))
+          (begin
+            (set! fp #f)
+            (abort-handler frame))))
+    
+    (new-enabled-trap
+     vm frame
+     (lambda (frame)
+       (if (not fp)
+           (error "return-or-abort traps may only be enabled once"))
+       (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
+       (add-hook! (vm-abort-continuation-hook vm) abort-hook)
+       (add-hook! (vm-restore-continuation-hook vm) abort-hook))
+     (lambda (frame)
+       (set! fp #f)
+       (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
+       (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
+       (remove-hook! (vm-restore-continuation-hook vm) abort-hook)))))
+
+;; A more traditional dynamic-wind trap. Perhaps this should not be
+;; based on the above trap-frame-finish?
+;;
+(define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
+                                 #:key current-frame (vm (the-vm)))
+  (arg-check proc procedure?)
+  (arg-check enter-handler procedure?)
+  (arg-check return-handler procedure?)
+  (arg-check abort-handler procedure?)
+  (let ((exit-trap #f))
+    (define (return-hook frame)
+      (exit-trap frame) ; disable the return/abort trap.
+      (set! exit-trap #f)
+      (return-handler frame))
+    
+    (define (abort-hook frame)
+      (exit-trap frame) ; disable the return/abort trap.
+      (set! exit-trap #f)
+      (abort-handler frame))
+    
+    (define (apply-hook frame)
+      (if (and (not exit-trap)
+               (eq? (frame-procedure frame) proc))
+          (begin
+            (enter-handler frame)
+            (set! exit-trap
+                  (trap-frame-finish frame return-hook abort-hook
+                                     #:vm vm)))))
+    
+    (new-enabled-trap
+     vm current-frame
+     (lambda (frame)
+       (add-hook! (vm-apply-hook vm) apply-hook))
+     (lambda (frame)
+       (if exit-trap
+           (abort-hook frame))
+       (set! exit-trap #f)
+       (remove-hook! (vm-apply-hook vm) apply-hook)))))
+
+;; Trapping all procedure calls within a dynamic extent, recording the
+;; depth of the call stack relative to the original procedure.
+;;
+(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
+                                       #:key current-frame (vm (the-vm)))
+  (arg-check proc procedure?)
+  (arg-check apply-handler procedure?)
+  (arg-check return-handler procedure?)
+  (let ((*call-depth* 0))
+    (define (trace-push frame)
+      (set! *call-depth* (1+ *call-depth*)))
+  
+    (define (trace-pop frame)
+      (return-handler frame *call-depth*)
+      (set! *call-depth* (1- *call-depth*)))
+  
+    (define (trace-apply frame)
+      (apply-handler frame *call-depth*))
+  
+    ;; FIXME: recalc depth on abort
+
+    (define (enter frame)
+      (add-hook! (vm-push-continuation-hook vm) trace-push)
+      (add-hook! (vm-pop-continuation-hook vm) trace-pop)
+      (add-hook! (vm-apply-hook vm) trace-apply))
+  
+    (define (leave frame)
+      (remove-hook! (vm-push-continuation-hook vm) trace-push)
+      (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
+      (remove-hook! (vm-apply-hook vm) trace-apply))
+  
+    (define (return frame)
+      (leave frame))
+  
+    (define (abort frame)
+      (leave frame))
+
+    (trap-in-dynamic-extent proc enter return abort
+                            #:current-frame current-frame #:vm vm)))
+
+;; Trapping all retired intructions within a dynamic extent.
+;;
+(define* (trap-instructions-in-dynamic-extent proc next-handler
+                                              #:key current-frame (vm (the-vm)))
+  (arg-check proc procedure?)
+  (arg-check next-handler procedure?)
+  (let ()
+    (define (trace-next frame)
+      (next-handler frame))
+  
+    (define (enter frame)
+      (add-hook! (vm-next-hook vm) trace-next))
+  
+    (define (leave frame)
+      (remove-hook! (vm-next-hook vm) trace-next))
+  
+    (define (return frame)
+      (leave frame))
+  
+    (define (abort frame)
+      (leave frame))
+
+    (trap-in-dynamic-extent proc enter return abort
+                            #:current-frame current-frame #:vm vm)))