scm/memory-trace.scm

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