X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmemory-trace.scm;h=345d1327f0f47f4ca4cdebe350b577f2fa077172;hb=19b37df119ff6ca84421d984fe1d33112ad08299;hp=dd86c491078a2f90e40cff2268062deb8f7627c6;hpb=e172d5758ac4e3755640dac9374bd9e7ca0c6ed6;p=lilypond.git

diff --git a/scm/memory-trace.scm b/scm/memory-trace.scm
index dd86c49107..345d1327f0 100644
--- a/scm/memory-trace.scm
+++ b/scm/memory-trace.scm
@@ -1,6 +1,9 @@
+;;;; memory-trace.scm
+
 (define-module (scm memory-trace))
+(use-modules (lily)
+	     (ice-9 format))
 
-(use-modules (ice-9 format))
 (define-public (mtrace:start-trace freq)
   (set! usecond-interval (inexact->exact (/ 1000000 freq)))
   (call-with-new-thread start-install-tracepoint))
@@ -16,6 +19,8 @@
 (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)
@@ -24,21 +29,33 @@
 	   (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 (assoc-get '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 'proc (arg-procedure args))
+		     (cons 'cells cells)
+		     (cons 'proc proc)
+		     (cons 'stack stack)
+		     (cons 'time time)
 		     )
 		    
 		    trace-points))
@@ -47,6 +64,12 @@
 
 (define (start-install-tracepoint)
   (set! trace-thread (current-thread))
+  (set! trace-points '())
+  (set! continue-tracing #t)
+  (set! trace-count 0)
+  (set! start-memory (assoc-get 'total-cells-allocated (gc-stats)))
+  (set! start-time (tms:utime (times)))
+  
   (install-tracepoint))
 
 (define (install-tracepoint)
@@ -62,37 +85,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)
-  (define last-mem 0) 
-  (format out "# memory trace with ~a points\n" (length trace-points))
-  
-  (for-each
-   (lambda (r)
-     (let*
-	 ((mem (cdr (assoc 'total-cells-allocated r)))
-	  (proc (cdr (assoc 'proc r)))
-	  (stack (cdr (assoc 'stack r))))
-       
-       (format out "~a ~a\n" i mem)
-       (if stack
-	   (begin
-	     (format stacks-out "~15a - delta-mem: ~15a - ~a \n" i
-		     (- 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)))
-
+  (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 (- (assoc-get 'cells r) start-memory))
+	    (proc (assoc-get 'proc r))
+	    (stack (assoc-get 'stack r))
+	    (time (- (assoc-get '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 (assoc-get '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)
@@ -125,9 +155,5 @@
     trace))
 
 
-
-
-
-