;;;; (statprof) -- a statistical profiler for Guile
;;;; -*-scheme-*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
;;;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
;;;;
(define-module (statprof)
#:use-module (srfi srfi-1)
#:autoload (ice-9 format) (format)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (system vm program)
#:export (statprof-active?
statprof-start
statprof-stop
statprof-fetch-stacks
statprof-fetch-call-tree
- with-statprof))
+ statprof
+ with-statprof
+
+ gcprof))
;; This profiler tracks two numbers for every function called while
(+ accumulated-time 0.0 (- ,stop-time last-start-time))))
(define (get-call-data proc)
- (or (hashq-ref procedure-data proc)
- (let ((call-data (make-call-data proc 0 0 0)))
- (hashq-set! procedure-data proc call-data)
- call-data)))
+ (let ((k (if (or (not (program? proc))
+ (zero? (program-num-free-variables proc)))
+ proc
+ (program-objcode proc))))
+ (or (hashq-ref procedure-data k)
+ (let ((call-data (make-call-data proc 0 0 0)))
+ (hashq-set! procedure-data k call-data)
+ call-data))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SIGPROF handler
;; and eliminate inside-profiler? because it seems to
;; confuse guile wrt re-enabling the trap when
;; count-call finishes.
- (if %count-calls? (trap-disable 'apply-frame))
+ (if %count-calls?
+ (set-vm-trace-level! (the-vm)
+ (1- (vm-trace-level (the-vm)))))
(accumulate-time stop-time)))
(setitimer ITIMER_PROF
(if (not inside-apply-trap?)
(begin
(set! last-start-time (get-internal-run-time))
- (if %count-calls? (trap-enable 'apply-frame))))))
-
+ (if %count-calls?
+ (set-vm-trace-level! (the-vm)
+ (1+ (vm-trace-level (the-vm)))))))))
+
(set! inside-profiler? #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Count total calls.
-(define (count-call trap-name continuation tail)
+(define (count-call frame)
(if (not inside-profiler?)
(begin
(accumulate-time (get-internal-run-time))
- (and=> (frame-procedure (last-stack-frame continuation))
+ (and=> (frame-procedure frame)
(lambda (proc)
(inc-call-data-call-count!
(get-call-data proc))))
0 0
(car sampling-frequency)
(cdr sampling-frequency)))
- (trap-enable 'apply-frame)
+ (if %count-calls?
+ (add-hook! (vm-apply-hook (the-vm)) count-call))
+ (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
#t)))
;; Do not call this from statprof internal functions -- user only.
(begin
(set! gc-time-taken
(- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
- (trap-disable 'apply-frame)
+ (set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm))))
+ (if %count-calls?
+ (remove-hook! (vm-apply-hook (the-vm)) count-call))
;; I believe that we need to do this before getting the time
;; (unless we want to make things even more complicated).
(set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
(accumulate-time (get-internal-run-time))
(set! last-start-time #f))))
-(define (statprof-reset sample-seconds sample-microseconds count-calls?
- . full-stacks?)
+(define* (statprof-reset sample-seconds sample-microseconds count-calls?
+ #:optional full-stacks?)
"Reset the statprof sampler interval to @var{sample-seconds} and
@var{sample-microseconds}. If @var{count-calls?} is true, arrange to
instrument procedure calls as well as collecting statistical profiling
(set! sampling-frequency (cons sample-seconds sample-microseconds))
(set! remaining-prof-time #f)
(set! procedure-data (make-hash-table 131))
- (if %count-calls?
- (begin
- (trap-set! apply-frame-handler count-call)
- (trap-enable 'traps)))
- (set! record-full-stacks? (and (pair? full-stacks?) (car full-stacks?)))
+ (set! record-full-stacks? full-stacks?)
(set! stacks '())
- (debug-enable 'debug)
(sigaction SIGPROF profile-signal-handler)
#t)
(if (zero? self-samples) 0.0
(/ (* self-samples secs-per-sample) 1.0 num-calls)))
(and num-calls ;; cum-samples must be positive
- (/ (* cum-samples secs-per-sample) 1.0 num-calls)))))
+ (/ (* cum-samples secs-per-sample)
+ 1.0
+ ;; num-calls might be 0 if we entered statprof during the
+ ;; dynamic extent of the call
+ (max num-calls 1))))))
(define (statprof-stats-proc-name stats) (vector-ref stats 0))
(define (statprof-stats-%-time-in-proc stats) (vector-ref stats 1))
(define (display-stats-line stats)
(if %count-calls?
- (format port "~6,2f ~9,2f ~9,2f ~8r ~8,2f ~8,2f "
+ (format port "~6,2f ~9,2f ~9,2f ~7d ~8,2f ~8,2f "
(statprof-stats-%-time-in-proc stats)
(statprof-stats-cum-secs-in-proc stats)
(statprof-stats-self-secs-in-proc stats)
(simple-format #t "Sample count: ~A\n" (statprof-sample-count))
(simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
(statprof-accumulated-time)
- (/ gc-time-taken internal-time-units-per-second))))))
+ (/ gc-time-taken 1.0 internal-time-units-per-second))))))
(define (statprof-display-anomolies)
"A sanity check that attempts to detect anomolies in statprof's
stacks)
(define procedure=?
- (if (false-if-exception (resolve-interface '(system base compile)))
- (lambda (a b)
- (cond
- ((eq? a b))
- ((and ((@ (system vm program) program?) a)
- ((@ (system vm program) program?) b))
- (eq? ((@ (system vm program) program-objcode) a)
- ((@ (system vm program) program-objcode) b)))
- ((and (closure? a) (closure? b)
- (procedure-source a) (procedure-source b))
- (and (eq? (procedure-name a) (procedure-name b))
- (equal? (procedure-source a) (procedure-source b))))
- (else
- #f)))
- (lambda (a b)
- (cond
- ((eq? a b))
- ((and (closure? a) (closure? b)
- (procedure-source a) (procedure-source b))
- (and (eq? (procedure-name a) (procedure-name b))
- (equal? (procedure-source a) (procedure-source b))))
- (else
- #f)))))
+ (lambda (a b)
+ (cond
+ ((eq? a b))
+ ((and (program? a) (program? b))
+ (eq? (program-objcode a) (program-objcode b)))
+ (else
+ #f))))
;; tree ::= (car n . tree*)
@end code"
(cons #t (lists->trees (map stack->procedures stacks) procedure=?)))
+(define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f)
+ (full-stacks? #f))
+ "Profiles the execution of @var{thunk}.
+
+The stack will be sampled @var{hz} times per second, and the thunk itself will
+be called @var{loop} times.
+
+If @var{count-calls?} is true, all procedure calls will be recorded. This
+operation is somewhat expensive.
+
+If @var{full-stacks?} is true, at each sample, statprof will store away the
+whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
+@code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
+
+ (dynamic-wind
+ (lambda ()
+ (statprof-reset (inexact->exact (floor (/ 1 hz)))
+ (inexact->exact (* 1e6 (- (/ 1 hz)
+ (floor (/ 1 hz)))))
+ count-calls?
+ full-stacks?)
+ (statprof-start))
+ (lambda ()
+ (let lp ((i loop))
+ (if (not (zero? i))
+ (begin
+ (thunk)
+ (lp (1- i))))))
+ (lambda ()
+ (statprof-stop)
+ (statprof-display)
+ (set! procedure-data #f))))
+
(define-macro (with-statprof . args)
"Profiles the expressions in its body.
((eq? kw #f def) ;; asking for the body
args)
(else def))) ;; kw not found
- (let ((loop (kw-arg-ref #:loop args #f))
- (hz (kw-arg-ref #:hz args 20))
- (count-calls? (kw-arg-ref #:count-calls? args #f))
- (full-stacks? (kw-arg-ref #:full-stacks? args #f))
- (body (kw-arg-ref #f args #f)))
- `(dynamic-wind
- (lambda ()
- (statprof-reset (inexact->exact (floor (/ 1 ,hz)))
- (inexact->exact (* 1e6 (- (/ 1 ,hz)
- (floor (/ 1 ,hz)))))
- ,count-calls?
- ,full-stacks?)
- (statprof-start))
- (lambda ()
- ,(if loop
- (let ((lp (gensym "statprof ")) (x (gensym)))
- `(let ,lp ((,x ,loop))
- (if (not (zero? ,x))
- (begin ,@body (,lp (1- ,x))))))
- `(begin ,@body)))
- (lambda ()
- (statprof-stop)
- (statprof-display)
- (set! (@@ (statprof) procedure-data) #f)))))
-
-;;; arch-tag: 83969178-b576-4c52-a31c-6a9c2be85d10
+ `((@ (statprof) statprof)
+ (lambda () ,@(kw-arg-ref #f args #f))
+ #:loop ,(kw-arg-ref #:loop args 1)
+ #:hz ,(kw-arg-ref #:hz args 100)
+ #:count-calls? ,(kw-arg-ref #:count-calls? args #f)
+ #:full-stacks? ,(kw-arg-ref #:full-stacks? args #f)))
+
+(define* (gcprof thunk #:key (loop 1) (full-stacks? #f))
+ "Do an allocation profile of the execution of @var{thunk}.
+
+The stack will be sampled soon after every garbage collection, yielding
+an approximate idea of what is causing allocation in your program.
+
+Since GC does not occur very frequently, you may need to use the
+@var{loop} parameter, to cause @var{thunk} to be called @var{loop}
+times.
+
+If @var{full-stacks?} is true, at each sample, statprof will store away the
+whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
+@code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
+
+ (define (reset)
+ (if (positive? profile-level)
+ (error "Can't reset profiler while profiler is running."))
+ (set! accumulated-time 0)
+ (set! last-start-time #f)
+ (set! sample-count 0)
+ (set! %count-calls? #f)
+ (set! procedure-data (make-hash-table 131))
+ (set! record-full-stacks? full-stacks?)
+ (set! stacks '()))
+
+ (define (gc-callback)
+ (cond
+ (inside-profiler?)
+ (else
+ (set! inside-profiler? #t)
+
+ ;; FIXME: should be able to set an outer frame for the stack cut
+ (let ((stop-time (get-internal-run-time))
+ ;; Cut down to gc-callback, and then one before (the
+ ;; after-gc async). See the note in profile-signal-handler
+ ;; also.
+ (stack (or (make-stack #t gc-callback 0 1)
+ (pk 'what! (make-stack #t)))))
+ (sample-stack-procs stack)
+ (accumulate-time stop-time)
+ (set! last-start-time (get-internal-run-time)))
+
+ (set! inside-profiler? #f))))
+
+ (define (start)
+ (set! profile-level (+ profile-level 1))
+ (if (= profile-level 1)
+ (begin
+ (set! remaining-prof-time #f)
+ (set! last-start-time (get-internal-run-time))
+ (set! gc-time-taken (cdr (assq 'gc-time-taken (gc-stats))))
+ (add-hook! after-gc-hook gc-callback)
+ (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
+ #t)))
+
+ (define (stop)
+ (set! profile-level (- profile-level 1))
+ (if (zero? profile-level)
+ (begin
+ (set! gc-time-taken
+ (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
+ (remove-hook! after-gc-hook gc-callback)
+ (accumulate-time (get-internal-run-time))
+ (set! last-start-time #f))))
+
+ (dynamic-wind
+ (lambda ()
+ (reset)
+ (start))
+ (lambda ()
+ (let lp ((i loop))
+ (if (not (zero? i))
+ (begin
+ (thunk)
+ (lp (1- i))))))
+ (lambda ()
+ (stop)
+ (statprof-display)
+ (set! procedure-data #f))))
HCoop / bpt / guile.git / blobdiff