scm/memory-trace.scm

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