scm/memory-trace.scm

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