]> git.donarmstrong.com Git - lilypond.git/blob - scm/memory-trace.scm
Merge with master
[lilypond.git] / scm / memory-trace.scm
1 (define-module (scm memory-trace))
2
3 (use-modules (ice-9 format))
4 (define-public (mtrace:start-trace freq)
5   (set! usecond-interval (inexact->exact (/ 1000000 freq)))
6   (call-with-new-thread start-install-tracepoint))
7
8 (define-public (mtrace:stop-trace)
9   (set! continue-tracing #f))
10
11 (define-public mtrace:trace-depth 12)
12
13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14
15 (define trace-points '())
16 (define continue-tracing #t)
17 (define busy-tracing #f)
18 (define trace-thread #f)
19
20 (define trace-count 0)
21 (define usecond-interval 100000)
22 (define (arg-procedure args)
23   (if (and (pair? args)
24            (pair? (cdr args))
25            (pair? (cadr args)))
26       (caadr args) #f))
27
28 (define (record-stack key continuation . args)
29   (if (eq? (current-thread) trace-thread)
30       #t ;; do nothing.
31       (begin
32         (set! busy-tracing #t)
33         (trap-disable 'traps)
34         (trap-disable 'enter-frame)
35         (set! trace-count (1+ trace-count))
36
37         (set! trace-points
38               (cons (list
39                      (assoc 'total-cells-allocated (gc-stats))
40                      (cons 'stack (extract-trace continuation))
41                      (cons 'proc (arg-procedure args))
42                      )
43                     
44                     trace-points))
45
46         (set! busy-tracing #f))))
47
48 (define (start-install-tracepoint)
49   (set! trace-thread (current-thread))
50   (install-tracepoint))
51
52 (define (install-tracepoint)
53   (if busy-tracing
54       (display "last trace not finished yet\n" (current-error-port))
55       (begin
56         (trap-set! enter-frame-handler record-stack)
57         (trap-enable 'enter-frame)
58         (trap-enable 'traps)))
59   
60   (usleep usecond-interval)
61   (if continue-tracing
62       (install-tracepoint)))
63
64 (define-public (mtrace:dump-results base)
65   (define out (open-output-file (format #f "~a.graph" base)))
66   (define stacks-out (open-output-file (format #f "~a.stacks" base)))
67   (define i 0)
68   (define last-mem 0) 
69   (format out "# memory trace with ~a points\n" (length trace-points))
70   
71   (for-each
72    (lambda (r)
73      (let*
74          ((mem (cdr (assoc 'total-cells-allocated r)))
75           (proc (cdr (assoc 'proc r)))
76           (stack (cdr (assoc 'stack r))))
77        
78        (format out "~a ~a\n" i mem)
79        (if stack
80            (begin
81              (format stacks-out "~15a - delta-mem: ~15a - ~a \n" i
82                      (- mem last-mem) proc)
83              (do
84                  ((j 0 (1+ j))
85                   (stack (cdr (assoc 'stack r)) stack))
86                  ((>= j (vector-length stack)))
87                
88                (format stacks-out "\t~a\n"
89                        (vector-ref stack j)))))
90        
91        (set! i (1+ i))
92        (set! last-mem mem)
93        ))
94    (reverse trace-points)))
95
96
97
98 (define (test-graph . rest)
99   (mtrace:start-trace 100)
100   (iota 100000)
101   (mtrace:stop-trace)
102   (mtrace:dump-results "test"))
103
104
105
106 (define (extract-trace continuation)
107   (let*
108       ((stack (make-stack continuation))
109        (depth (min (stack-length stack) mtrace:trace-depth))
110        (trace (make-vector depth #f)))
111
112     (do
113         ((i 0 (1+ i)))
114         ((>= i depth))
115
116       (vector-set!
117        trace i
118        (let*
119            ((source (frame-source (stack-ref stack i))))
120
121            (and source
122                 (cons (source-property source 'filename)
123                       (source-property source 'line))))))
124
125     trace))
126
127
128
129
130
131
132        
133