Add version numbers to fretboard files.

[lilypond.git] / scm / memory-trace.scm

diff --git a/scm/memory-trace.scm b/scm/memory-trace.scm
index 100e1f233a3286a653779d6403cdaf06aafd9932..0b636377cceb580f793aa39d68e4141bf12a6963 100644 (file)
--- a/scm/memory-trace.scm
+++ b/scm/memory-trace.scm
@@ -1,5 +1,6 @@
 (define-module (scm memory-trace))
-
+(use-modules (lily)
+            (ice-9 format))
 
 (define-public (mtrace:start-trace freq)
   (set! usecond-interval (inexact->exact (/ 1000000 freq)))
@@ -8,7 +9,7 @@
 (define-public (mtrace:stop-trace)
   (set! continue-tracing #f))
 
-(define-public mtrace:trace-depth 8)
+(define-public mtrace:trace-depth 12)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -16,29 +17,57 @@
 (define continue-tracing #t)
 (define busy-tracing #f)
 (define trace-thread #f)
+(define start-time 0)
+(define start-memory 0)
 
 (define trace-count 0)
 (define usecond-interval 100000)
-
+(define (arg-procedure args)
+  (if (and (pair? args)
+          (pair? (cdr args))
+          (pair? (cadr args)))
+      (caadr args) #f))
+(define last-count 0)
 (define (record-stack key continuation . args)
   (if (eq? (current-thread) trace-thread)
       #t ;; do nothing.
-      (begin
+      (let*
+         ((cells (cdr (assoc 'total-cells-allocated (gc-stats))))
+          (proc (arg-procedure args))
+          (time (tms:utime (times)))
+          (stack (extract-trace continuation)))
+       
        (set! busy-tracing #t)
        (trap-disable 'traps)
        (trap-disable 'enter-frame)
+
        (set! trace-count (1+ trace-count))
+       (ly:progress "<~a: ~a/~a>\n"
+                    trace-count
+                    (- time start-time)
+                    (- cells last-count))
 
+       (set! last-count cells)
        (set! trace-points
              (cons (list
-                    (assoc 'total-cells-allocated  (gc-stats))
-                    (cons 'stack (extract-trace continuation)))
+                    (cons 'cells cells)
+                    (cons 'proc proc)
+                    (cons 'stack stack)
+                    (cons 'time time)
+                    )
+                   
                    trace-points))
 
        (set! busy-tracing #f))))
 
 (define (start-install-tracepoint)
   (set! trace-thread (current-thread))
+  (set! trace-points '())
+  (set! continue-tracing #t)
+  (set! trace-count 0)
+  (set! start-memory (cdr (assoc 'total-cells-allocated (gc-stats))))
+  (set! start-time (tms:utime (times)))
+  
   (install-tracepoint))
 
 (define (install-tracepoint)
@@ -54,25 +83,44 @@
       (install-tracepoint)))
 
 (define-public (mtrace:dump-results base)
-  (define out (open-output-file (format #f "~a.graph" base)))
-  (define stacks-out (open-output-file (format #f "~a.stacks" base)))
-  (define i 0)
-
-  (format out "# memory trace with ~a points\n" (length trace-points))
-  
-  (for-each
-   (lambda (r)
-     (format out "~a ~a\n" i
-            (cdr (assoc 'total-cells-allocated r)))
-
-     (if (assoc 'stack r)
-        (format stacks-out "~a: ~a\n"
-                i
-                (cdr (assoc 'stack r))))
-     
-     (set! i (1+ i)))
-   (reverse trace-points)))
-
+  (let*
+      ((stacks-name (format #f "~a.stacks" base))
+       (graph-name (format #f "~a.graph" base))
+       (graph-out (open-output-file graph-name))
+       (stacks-out (open-output-file stacks-name))
+       (i 0)
+       (last-mem 0)
+       )
+
+    (ly:progress "Memory statistics to ~a and ~a..."
+                stacks-name graph-name)
+    (format graph-out "# memory trace with ~a points\n" (length trace-points))
+    (for-each
+     (lambda (r)
+       (let*
+          ((mem (- (cdr (assoc 'cells r)) start-memory))
+           (proc (cdr (assoc 'proc r)))
+           (stack (cdr (assoc 'stack r)))
+           (time (- (cdr (assoc 'time r)) start-time)))
+        
+        (format graph-out "~a ~a\n" time mem)
+        (if stack
+            (begin
+              (format stacks-out "~5a t = ~5a - delta-mem: ~15a - ~a \n" i
+                      time
+                      (- mem last-mem) proc)
+              (do
+                  ((j 0 (1+ j))
+                   (stack (cdr (assoc 'stack r)) stack))
+                  ((>= j (vector-length stack)))
+                
+                (format stacks-out "\t~a\n"
+                        (vector-ref stack j)))))
+        
+        (set! i (1+ i))
+        (set! last-mem mem)
+        ))
+     (reverse trace-points))))
 
 
 (define (test-graph . rest)
@@ -105,9 +153,5 @@
     trace))
 
 
-
-
-
-