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 c8c3a010ac14856cbfab72bb61a87d6c8bfbef67..b05c576c8e7905d3f41cfe4d8bce77d037e9a14d 100644 (file)
--- 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 (file)
index 0000000..100e1f2
--- /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))
+
+
+
+
+
+
+       
+