add repl ,tracepoint command

* module/system/vm/trace.scm (print-return, print-application)
  (frame-return-values): Factored out of other things.
  (trace-calls-to-procedure): New proc, installs a trap tracing only
  calls to the given proc.
  (trace-calls-in-procedure): Refactor a bit.

* module/system/vm/trap-state.scm (add-trace-at-procedure-call!): New
  proc.

* module/system/repl/command.scm (tracepoint): New command, installs a
  tracepoint on a procedure.

diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index cb467ce..4973b91 100644 (file)
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -57,7 +57,7 @@
     (profile  (time t) (profile pr) (trace tr))
     (debug    (backtrace bt) (up) (down) (frame fr)
               (procedure proc) (locals) (error-message error)
-              (break br)
+              (break br bp) (tracepoint tp)
               (traps) (delete del) (disable) (enable))
     (inspect  (inspect i) (pretty-print pp))
     (system   (gc) (statistics stat) (option o)
@@ -580,6 +580,18 @@ Starts a recursive prompt when PROCEDURE is called."
         (let ((idx (add-trap-at-procedure-call! proc)))
           (format #t "Added breakpoint ~a at ~a.~%" idx proc)))))
 
+(define-meta-command (tracepoint repl (form))
+  "tracepoint PROCEDURE
+Add a tracepoint to PROCEDURE.
+
+A tracepoint will print out the procedure and its arguments, when it is
+called, and its return value(s) when it returns."
+  (let ((proc (repl-eval repl (repl-parse repl form))))
+    (if (not (procedure? proc))
+        (error "Not a procedure: ~a" proc)
+        (let ((idx (add-trace-at-procedure-call! proc)))
+          (format #t "Added tracepoint ~a at ~a.~%" idx proc)))))
+
 (define-meta-command (traps repl)
   "traps
 Show the set of currently attached traps.

diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 4b66738..097e3e8 100644 (file)
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -29,52 +29,58 @@
   #:use-module (system vm instruction)
   #:use-module (ice-9 format)
   #:export (trace-calls-in-procedure
+            trace-calls-to-procedure
             trace-instructions-in-procedure
             vm-trace))
 
 ;; FIXME: this constant needs to go in system vm objcode
 (define *objcode-header-len* 8)
 
-(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 (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 #\|)
-            (max (- width depth) 1)
-            (frame-call-representation frame)))
+(define (print-application frame depth width)
+  (format (current-error-port) "~a~v:@y\n"
+          (make-string depth #\|)
+          (max (- width depth) 1)
+          (frame-call-representation frame)))
 
-  (define (print-return frame 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 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 depth #\|)
-                nvalues
-                (map (lambda (val)
-                       (format #f "~v:@y" width val))
-                     (frame-return-values frame)))))))
-  
-  (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 (print-return frame depth width)
+  (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 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 depth #\|)
+              nvalues
+              (map (lambda (val)
+                     (format #f "~v:@y" width val))
+                   (frame-return-values frame)))))))
   
-  (trap-calls-in-dynamic-extent proc print-application print-return
+(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm)))
+  (define (apply-handler frame depth)
+    (print-application frame depth width))
+  (define (return-handler frame depth)
+    (print-return frame depth width))
+  (trap-calls-to-procedure proc apply-handler return-handler
+                           #:vm vm))
+
+(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm)))
+  (define (apply-handler frame depth)
+    (print-application frame depth width))
+  (define (return-handler frame depth)
+    (print-return frame depth width))
+  (trap-calls-in-dynamic-extent proc apply-handler return-handler
                                 #:vm vm))
 
 (define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm)))

diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index 68caf9f..fea46d2 100644 (file)
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -25,6 +25,7 @@
   #:use-module ((srfi srfi-1) #:select (fold))
   #:use-module (system vm vm)
   #:use-module (system vm traps)
+  #:use-module (system vm trace)
   #:export (list-traps
             trap-enabled?
             enable-trap!
@@ -34,7 +35,8 @@
             with-default-trap-handler
             install-trap-handler!
 
-            add-trap-at-procedure-call!))
+            add-trap-at-procedure-call!
+            add-trace-at-procedure-call!))
 
 (define %default-trap-handler (make-fluid))
 
@@ -192,6 +194,16 @@
       idx #t trap
       (format #f "breakpoint at ~a" proc)))))
 
+(define* (add-trace-at-procedure-call! proc
+                                       #:optional (trap-state (the-trap-state)))
+  (let* ((idx (next-index! trap-state))
+         (trap (trace-calls-to-procedure proc)))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (format #f "tracepoint at ~a" proc)))))
+
 (define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
   (let* ((idx (next-index! trap-state)))
     (add-trap-wrapper!