From: Han-Wen Nienhuys <hanwen@xs4all.nl>
Date: Wed, 17 Jan 2007 12:28:39 +0000 (+0100)
Subject: Add -dtrace-memory.
X-Git-Tag: release/2.11.12-1~10
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=9dd9d6fab2e3296bd8df5e105886b50043057ad0;p=lilypond.git

Add -dtrace-memory.

Use GUILE evaluator trap to record memory use during a lily run.
Write FILE.graph and FILE.stacks to record results.
---

diff --git a/scm/lily.scm b/scm/lily.scm
index c8c3a010ac..b05c576c8e 100644
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -70,6 +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.")
 	      (ttf-verbosity 0
 			     "how much verbosity for TTF font embedding?")
 	      (show-available-fonts #f
@@ -106,6 +107,7 @@ on errors, and print a stack trace.")
 	     (srfi srfi-13)
 	     (srfi srfi-14)
 	     (scm clip-region)
+	     (scm memory-trace)
 	     )
 
 ;; my display
@@ -651,11 +653,18 @@ 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))
+	 
 	 (lilypond-file handler x)
 	 (if start-measurements
 	     (dump-profile x start-measurements (profile-measurements)))
-       
+
+	 (if (ly:get-option 'trace-memory)
+	     (begin
+	       (mtrace:stop-trace)
+	       (mtrace:dump-results base)))
+	  	 
 	 (for-each
 	  (lambda (s)
 	    (ly:set-option (car s) (cdr s)))
diff --git a/scm/memory-trace.scm b/scm/memory-trace.scm
new file mode 100644
index 0000000000..100e1f233a
--- /dev/null
+++ b/scm/memory-trace.scm
@@ -0,0 +1,113 @@
+(define-module (scm memory-trace))
+
+
+(define-public (mtrace:start-trace freq)
+  (set! usecond-interval (inexact->exact (/ 1000000 freq)))
+  (call-with-new-thread start-install-tracepoint))
+
+(define-public (mtrace:stop-trace)
+  (set! continue-tracing #f))
+
+(define-public mtrace:trace-depth 8)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define trace-points '())
+(define continue-tracing #t)
+(define busy-tracing #f)
+(define trace-thread #f)
+
+(define trace-count 0)
+(define usecond-interval 100000)
+
+(define (record-stack key continuation . args)
+  (if (eq? (current-thread) trace-thread)
+      #t ;; do nothing.
+      (begin
+	(set! busy-tracing #t)
+	(trap-disable 'traps)
+	(trap-disable 'enter-frame)
+	(set! trace-count (1+ trace-count))
+
+	(set! trace-points
+	      (cons (list
+		     (assoc 'total-cells-allocated  (gc-stats))
+		     (cons 'stack (extract-trace continuation)))
+		    trace-points))
+
+	(set! busy-tracing #f))))
+
+(define (start-install-tracepoint)
+  (set! trace-thread (current-thread))
+  (install-tracepoint))
+
+(define (install-tracepoint)
+  (if busy-tracing
+      (display "last trace not finished yet\n" (current-error-port))
+      (begin
+	(trap-set! enter-frame-handler record-stack)
+	(trap-enable 'enter-frame)
+	(trap-enable 'traps)))
+  
+  (usleep usecond-interval)
+  (if continue-tracing
+      (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)))
+
+
+
+(define (test-graph . rest)
+  (mtrace:start-trace 100)
+  (iota 100000)
+  (mtrace:stop-trace)
+  (mtrace:dump-results "test"))
+
+
+
+(define (extract-trace continuation)
+  (let*
+      ((stack (make-stack continuation))
+       (depth (min (stack-length stack) mtrace:trace-depth))
+       (trace (make-vector depth #f)))
+
+    (do
+	((i 0 (1+ i)))
+	((>= i depth))
+
+      (vector-set!
+       trace i
+       (let*
+	   ((source (frame-source (stack-ref stack i))))
+
+	   (and source
+		(cons (source-property source 'filename)
+		      (source-property source 'line))))))
+
+    trace))
+
+
+
+
+
+
+       
+