From 5da4ee03faadffd59fcbdd6faf976216e6c4978a Mon Sep 17 00:00:00 2001
From: NalaGinrut <address@hidden>
Date: Tue, 28 Feb 2012 17:45:08 +0800
Subject: [PATCH] Add new trace print style, show level count number instead lots of '| | |...'

	modified:   module/system/vm/trace.scm
---
 module/system/vm/trace.scm |   55 ++++++++++++++++++++++++++++++++------------
 1 files changed, 40 insertions(+), 15 deletions(-)

diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 2dad376..99f28ca 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -36,17 +36,23 @@
 ;; FIXME: this constant needs to go in system vm objcode
 (define *objcode-header-len* 8)
 
-(define (print-application frame depth width prefix)
+(define (print-application frame depth width prefix mode)
   (format (current-error-port) "~a~a~v:@y\n"
           prefix
           (let lp ((depth depth) (s ""))
             (if (zero? depth)
                 s
-                (lp (1- depth) (string-append "|  " s))))
+                (case mode
+                  ((graph)
+                   (lp (1- depth) (string-append "|  " s)))
+                  ((count)
+                   (format #f "~a: ~a" depth s))
+                  (else
+                   (error "invalid print mode" mode)))))
           (max (- width (* 3 depth)) 1)
           (frame-call-representation frame)))
 
-(define (print-return frame depth width prefix)
+(define* (print-return frame depth width prefix mode)
   (let* ((len (frame-num-locals frame))
          (nvalues (frame-local-ref frame (1- len))))
     (cond
@@ -56,7 +62,13 @@
               (let lp ((depth depth) (s ""))
                 (if (zero? depth)
                     s
-                    (lp (1- depth) (string-append "|  " s))))
+                    (case mode
+                     ((graph)
+                      (lp (1- depth) (string-append "|  " s)))
+                     ((count)
+                      (format #f "~a: ~a" depth s))
+                     (else
+                      (error "invalid print mode" mode)))))
               width (frame-local-ref frame (- len 2))))
      (else
       ;; this should work, but there appears to be a bug
@@ -66,31 +78,38 @@
               (let lp ((depth depth) (s ""))
                 (if (zero? depth)
                     s
-                    (lp (1- depth) (string-append "|  " s))))
+                    (case mode
+                     ((graph)
+                      (lp (1- depth) (string-append "|  " s)))
+                     ((count)
+                      (format #f "~a: ~a" depth s))
+                     (else
+                      (error "invalid print mode" mode)))))
               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))
-                                   (prefix "trace: "))
+                                   (prefix "trace: ") (mode 'count))
   (define (apply-handler frame depth)
-    (print-application frame depth width prefix))
+    (print-application frame depth width prefix mode))
   (define (return-handler frame depth)
-    (print-return frame depth width prefix))
+    (print-return frame depth width prefix mode))
   (trap-calls-to-procedure proc apply-handler return-handler
                            #:vm vm))
 
 (define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
-                                   (prefix "trace: "))
+                                   (prefix "trace: ") (mode 'count))
   (define (apply-handler frame depth)
-    (print-application frame depth width prefix))
+    (print-application frame depth width prefix mode))
   (define (return-handler frame depth)
-    (print-return frame depth width prefix))
+    (print-return frame depth width prefix mode))
   (trap-calls-in-dynamic-extent proc apply-handler return-handler
                                 #:vm vm))
 
-(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm)))
+(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
+                                          (mode 'count))
   (define (trace-next frame)
     (let* ((ip (frame-instruction-pointer frame))
            (objcode (program-objcode (frame-procedure frame)))
@@ -104,17 +123,23 @@
 ;; Note that because this procedure manipulates the VM trace level
 ;; directly, it doesn't compose well with traps at the REPL.
 ;;
-(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f) (width 80) (vm (the-vm)))
+;; mode has two options:
+;; 1. 'graph for old style which print "|  " msg
+;; 2. 'count for new style which print level count number + msg
+;; The 'count style is aim to alleviate the pain when tracing very deep level.
+(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f) 
+                          (width 80) (mode 'count) (vm (the-vm)))
   (let ((call-trap #f)
         (inst-trap #f))
     (dynamic-wind
       (lambda ()
         (if calls?
             (set! call-trap
-                  (trace-calls-in-procedure thunk #:vm vm #:width width)))
+                  (trace-calls-in-procedure thunk #:vm vm #:width width #:mode mode)))
         (if instructions?
             (set! inst-trap
-                  (trace-instructions-in-procedure thunk #:vm vm #:width width)))
+                  (trace-instructions-in-procedure thunk #:vm vm #:width width 
+                                                   #:mode mode)))
         (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
       thunk
       (lambda ()
-- 
1.7.0.4