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       (begin
  35         (set! busy-tracing #t)
  36         (trap-disable 'traps)
  37         (trap-disable 'enter-frame)
  38
  39         (set! trace-count (1+ trace-count))
  40         (ly:progress "<~a: ~a>\n"
  41                      trace-count
  42                      (- (cdr (assoc 'total-cells-allocated (gc-stats))) last-count))
  43         (set! last-count (cdr (assoc 'total-cells-allocated (gc-stats))))
  44         (set! trace-points
  45               (cons (list
  46                      (assoc 'total-cells-allocated (gc-stats))
  47                      (cons 'stack (extract-trace continuation))
  48                      (cons 'proc (arg-procedure args))
  49                      (cons 'time (tms:utime (times)))
  50                      )
  51
  52                     trace-points))
  53
  54         (set! busy-tracing #f))))
  55
  56 (define (start-install-tracepoint)
  57   (set! trace-thread (current-thread))
  58   (set! trace-points '())
  59   (set! continue-tracing #t)
  60   (set! trace-count 0)
  61   (set! start-memory (cdr (assoc 'total-cells-allocated (gc-stats))))
  62   (set! start-time (tms:utime (times)))
  63
  64   (install-tracepoint))
  65
  66 (define (install-tracepoint)
  67   (if busy-tracing
  68       (display "last trace not finished yet\n" (current-error-port))
  69       (begin
  70         (trap-set! enter-frame-handler record-stack)
  71         (trap-enable 'enter-frame)
  72         (trap-enable 'traps)))
  73
  74   (usleep usecond-interval)
  75   (if continue-tracing
  76       (install-tracepoint)))
  77
  78 (define-public (mtrace:dump-results base)
  79   (let*
  80       ((stacks-name (format #f "~a.stacks" base))
  81        (graph-name (format #f "~a.graph" base))
  82        (graph-out (open-output-file graph-name))
  83        (stacks-out (open-output-file stacks-name))
  84        (i 0)
  85        (last-mem 0)
  86        )
  87
  88     (ly:progress "Memory statistics to ~a and ~a..."
  89                  stacks-name graph-name)
  90     (format graph-out "# memory trace with ~a points\n" (length trace-points))
  91     (for-each
  92      (lambda (r)
  93        (let*
  94            ((mem (- (cdr (assoc 'total-cells-allocated r)) start-memory))
  95             (proc (cdr (assoc 'proc r)))
  96             (stack (cdr (assoc 'stack r)))
  97             (time (- (cdr (assoc 'time r)) start-time)))
  98
  99          (format graph-out "~a ~a\n" time mem)
 100          (if stack
 101              (begin
 102                (format stacks-out "~5a t = ~5a - delta-mem: ~15a - ~a \n" i
 103                        time
 104                        (- mem last-mem) proc)
 105                (do
 106                    ((j 0 (1+ j))
 107                     (stack (cdr (assoc 'stack r)) stack))
 108                    ((>= j (vector-length stack)))
 109
 110                  (format stacks-out "\t~a\n"
 111                          (vector-ref stack j)))))
 112
 113          (set! i (1+ i))
 114          (set! last-mem mem)
 115          ))
 116      (reverse trace-points))))
 117
 118
 119 (define (test-graph . rest)
 120   (mtrace:start-trace 100)
 121   (iota 100000)
 122   (mtrace:stop-trace)
 123   (mtrace:dump-results "test"))
 124
 125
 126
 127 (define (extract-trace continuation)
 128   (let*
 129       ((stack (make-stack continuation))
 130        (depth (min (stack-length stack) mtrace:trace-depth))
 131        (trace (make-vector depth #f)))
 132
 133     (do
 134         ((i 0 (1+ i)))
 135         ((>= i depth))
 136
 137       (vector-set!
 138        trace i
 139        (let*
 140            ((source (frame-source (stack-ref stack i))))
 141
 142            (and source
 143                 (cons (source-property source 'filename)
 144                       (source-property source 'line))))))
 145
 146     trace))
 147
 148
 149
 150