+;;;; memory-trace.scm
+
(define-module (scm memory-trace))
(use-modules (lily)
(ice-9 format))
(define (record-stack key continuation . args)
(if (eq? (current-thread) trace-thread)
#t ;; do nothing.
- (begin
+ (let*
+ ((cells (assoc-get 'total-cells-allocated (gc-stats)))
+ (proc (arg-procedure args))
+ (time (tms:utime (times)))
+ (stack (extract-trace continuation)))
+
(set! busy-tracing #t)
(trap-disable 'traps)
(trap-disable 'enter-frame)
(set! trace-count (1+ trace-count))
- (ly:progress "<~a: ~a>\n"
+ (ly:progress "<~a: ~a/~a>\n"
trace-count
- (- (cdr (assoc 'total-cells-allocated (gc-stats))) last-count))
- (set! last-count (cdr (assoc 'total-cells-allocated (gc-stats))))
+ (- time start-time)
+ (- cells last-count))
+
+ (set! last-count cells)
(set! trace-points
(cons (list
- (assoc 'total-cells-allocated (gc-stats))
- (cons 'stack (extract-trace continuation))
- (cons 'proc (arg-procedure args))
- (cons 'time (tms:utime (times)))
+ (cons 'cells cells)
+ (cons 'proc proc)
+ (cons 'stack stack)
+ (cons 'time time)
)
trace-points))
(set! trace-points '())
(set! continue-tracing #t)
(set! trace-count 0)
- (set! start-memory (cdr (assoc 'total-cells-allocated (gc-stats))))
+ (set! start-memory (assoc-get 'total-cells-allocated (gc-stats)))
(set! start-time (tms:utime (times)))
(install-tracepoint))
(for-each
(lambda (r)
(let*
- ((mem (- (cdr (assoc 'total-cells-allocated r)) start-memory))
- (proc (cdr (assoc 'proc r)))
- (stack (cdr (assoc 'stack r)))
- (time (- (cdr (assoc 'time r)) start-time)))
+ ((mem (- (assoc-get 'cells r) start-memory))
+ (proc (assoc-get 'proc r))
+ (stack (assoc-get 'stack r))
+ (time (- (assoc-get 'time r) start-time)))
(format graph-out "~a ~a\n" time mem)
(if stack
(begin
- (format stacks-out "~5a t = ~5a - delta-mem: ~15a - ~a \n" i
+ (format stacks-out "~5a t = ~5a - delta-mem: ~15a - ~a\n" i
time
(- mem last-mem) proc)
(do
((j 0 (1+ j))
- (stack (cdr (assoc 'stack r)) stack))
+ (stack (assoc-get 'stack r) stack))
((>= j (vector-length stack)))
(format stacks-out "\t~a\n"