tracepoints print their trap number

* module/system/vm/trace.scm (print-application, print-return): Add a
  prefix before the printout.
  (trace-calls-to-procedure, trace-calls-in-procedure): Add prefix
  keyword args.

* module/system/vm/trap-state.scm (add-trace-at-procedure-call!): Give a
  useful prefix for tracepoint printouts.

diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 097e3e8..0c878e3 100644 (file)
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -43,43 +43,45 @@
            (frame-local-ref frame (+ (- len nvalues) i)))
          (iota nvalues))))
   
-(define (print-application frame depth width)
-  (format (current-error-port) "~a~v:@y\n"
-          (make-string depth #\|)
+(define (print-application frame depth width prefix)
+  (format (current-error-port) "~a~a~v:@y\n"
+          prefix (make-string depth #\|)
           (max (- width depth) 1)
           (frame-call-representation frame)))
 
-(define (print-return frame depth width)
+(define (print-return frame depth width prefix)
   (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 #\|)
+      (format (current-error-port) "~a~a~v:@y\n"
+              prefix (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 #\|)
+      (format (current-error-port) "~a ~a~d values:~{ ~a~}\n"
+              prefix (make-string depth #\|)
               nvalues
               (map (lambda (val)
                      (format #f "~v:@y" width val))
                    (frame-return-values frame)))))))
   
-(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm)))
+(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
+                                   (prefix "trace: "))
   (define (apply-handler frame depth)
-    (print-application frame depth width))
+    (print-application frame depth width prefix))
   (define (return-handler frame depth)
-    (print-return frame depth width))
+    (print-return frame depth width prefix))
   (trap-calls-to-procedure proc apply-handler return-handler
                            #:vm vm))
 
-(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm)))
+(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
+                                   (prefix "trace: "))
   (define (apply-handler frame depth)
-    (print-application frame depth width))
+    (print-application frame depth width prefix))
   (define (return-handler frame depth)
-    (print-return frame depth width))
+    (print-return frame depth width prefix))
   (trap-calls-in-dynamic-extent proc apply-handler return-handler
                                 #:vm vm))
 

diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index fea46d2..df553ba 100644 (file)
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -197,7 +197,9 @@
 (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)))
+         (trap (trace-calls-to-procedure
+                proc
+                #:prefix (format #f "trace trap ~a: " idx))))
     (add-trap-wrapper!
      trap-state
      (make-trap-wrapper