scm/memory-trace.scm

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