;;;; (statprof) -- a statistical profiler for Guile
;;;; -*-scheme-*-
;;;;
-;;;; Copyright (C) 2009, 2010 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>
;;;;
statprof-fetch-call-tree
statprof
- with-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
0 0
(car sampling-frequency)
(cdr sampling-frequency)))
- (add-hook! (vm-apply-hook (the-vm)) count-call)
+ (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)))
(set! gc-time-taken
(- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
(set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm))))
- (remove-hook! (vm-apply-hook (the-vm)) count-call)
+ (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))
- (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)
(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 (program? a) (program? b))
- (eq? (program-objcode a) (program-objcode 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*)
#: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