From: Han-Wen Nienhuys <hanwen@xs4all.nl>
Date: Wed, 17 Jan 2007 13:46:02 +0000 (+0100)
Subject: memory-tracing refinements.
X-Git-Tag: release/2.11.12-1~8
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=7c05d44fd79e07fd35a1bea9d1af7cc15a435647;p=lilypond.git

memory-tracing refinements.
---

diff --git a/scm/lily.scm b/scm/lily.scm
index b05c576c8e..a0940d9be9 100644
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -70,7 +70,7 @@ on errors, and print a stack trace.")
 	      (safe #f "Run safely")
 	      (strict-infinity-checking #f "If yes, crash on encountering Inf/NaN.")
 	      (separate-log-files #f "Output to FILE.log per file.")
-	      (trace-memory #f "Statistically record Scheme cell usage, and dump to file.")
+	      (trace-memory-frequency #f "Record Scheme cell usage this many times per second, and dump to file.")
 	      (ttf-verbosity 0
 			     "how much verbosity for TTF font embedding?")
 	      (show-available-fonts #f
@@ -653,14 +653,14 @@ The syntax is the same as `define*-public'."
 
 	 (if separate-logs
 	     (ly:stderr-redirect (format "~a.log" base) "w"))
-	 (if (ly:get-option 'trace-memory) 
-	     (mtrace:start-trace 50))
+	 (if (ly:get-option 'trace-memory-frequency) 
+	     (mtrace:start-trace  (ly:get-option 'trace-memory-frequency)))
 	 
 	 (lilypond-file handler x)
 	 (if start-measurements
 	     (dump-profile x start-measurements (profile-measurements)))
 
-	 (if (ly:get-option 'trace-memory)
+	 (if (ly:get-option 'trace-memory-frequency)
 	     (begin
 	       (mtrace:stop-trace)
 	       (mtrace:dump-results base)))
diff --git a/scm/memory-trace.scm b/scm/memory-trace.scm
index 100e1f233a..dd86c49107 100644
--- a/scm/memory-trace.scm
+++ b/scm/memory-trace.scm
@@ -1,6 +1,6 @@
 (define-module (scm memory-trace))
 
-
+(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))
@@ -8,7 +8,7 @@
 (define-public (mtrace:stop-trace)
   (set! continue-tracing #f))
 
-(define-public mtrace:trace-depth 8)
+(define-public mtrace:trace-depth 12)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -19,6 +19,11 @@
 
 (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 (record-stack key continuation . args)
   (if (eq? (current-thread) trace-thread)
@@ -31,8 +36,11 @@
 
 	(set! trace-points
 	      (cons (list
-		     (assoc 'total-cells-allocated  (gc-stats))
-		     (cons 'stack (extract-trace continuation)))
+		     (assoc 'total-cells-allocated (gc-stats))
+		     (cons 'stack (extract-trace continuation))
+		     (cons 'proc (arg-procedure args))
+		     )
+		    
 		    trace-points))
 
 	(set! busy-tracing #f))))
@@ -57,20 +65,32 @@
   (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)
-     (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)))
+     (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)))