scm/memory-trace.scm

   1 (define-module (scm memory-trace))
   2
   3
   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 8)
  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
  23 (define (record-stack key continuation . args)
  24   (if (eq? (current-thread) trace-thread)
  25       #t ;; do nothing.
  26       (begin
  27         (set! busy-tracing #t)
  28         (trap-disable 'traps)
  29         (trap-disable 'enter-frame)
  30         (set! trace-count (1+ trace-count))
  31
  32         (set! trace-points
  33               (cons (list
  34                      (assoc 'total-cells-allocated  (gc-stats))
  35                      (cons 'stack (extract-trace continuation)))
  36                     trace-points))
  37
  38         (set! busy-tracing #f))))
  39
  40 (define (start-install-tracepoint)
  41   (set! trace-thread (current-thread))
  42   (install-tracepoint))
  43
  44 (define (install-tracepoint)
  45   (if busy-tracing
  46       (display "last trace not finished yet\n" (current-error-port))
  47       (begin
  48         (trap-set! enter-frame-handler record-stack)
  49         (trap-enable 'enter-frame)
  50         (trap-enable 'traps)))
  51
  52   (usleep usecond-interval)
  53   (if continue-tracing
  54       (install-tracepoint)))
  55
  56 (define-public (mtrace:dump-results base)
  57   (define out (open-output-file (format #f "~a.graph" base)))
  58   (define stacks-out (open-output-file (format #f "~a.stacks" base)))
  59   (define i 0)
  60
  61   (format out "# memory trace with ~a points\n" (length trace-points))
  62
  63   (for-each
  64    (lambda (r)
  65      (format out "~a ~a\n" i
  66              (cdr (assoc 'total-cells-allocated r)))
  67
  68      (if (assoc 'stack r)
  69          (format stacks-out "~a: ~a\n"
  70                  i
  71                  (cdr (assoc 'stack r))))
  72
  73      (set! i (1+ i)))
  74    (reverse trace-points)))
  75
  76
  77
  78 (define (test-graph . rest)
  79   (mtrace:start-trace 100)
  80   (iota 100000)
  81   (mtrace:stop-trace)
  82   (mtrace:dump-results "test"))
  83
  84
  85
  86 (define (extract-trace continuation)
  87   (let*
  88       ((stack (make-stack continuation))
  89        (depth (min (stack-length stack) mtrace:trace-depth))
  90        (trace (make-vector depth #f)))
  91
  92     (do
  93         ((i 0 (1+ i)))
  94         ((>= i depth))
  95
  96       (vector-set!
  97        trace i
  98        (let*
  99            ((source (frame-source (stack-ref stack i))))
 100
 101            (and source
 102                 (cons (source-property source 'filename)
 103                       (source-property source 'line))))))
 104
 105     trace))
 106
 107
 108
 109
 110
 111
 112
 113