summaryrefslogtreecommitdiff
path: root/module/statprof.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/statprof.scm')
-rw-r--r--module/statprof.scm93
1 files changed, 87 insertions, 6 deletions
diff --git a/module/statprof.scm b/module/statprof.scm
index da6f3f1fc..33246e5bd 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -1,7 +1,7 @@
;;;; (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>
;;;;
@@ -159,7 +159,9 @@
statprof-fetch-call-tree
statprof
- with-statprof))
+ with-statprof
+
+ gcprof))
;; This profiler tracks two numbers for every function called while
@@ -379,8 +381,8 @@ than @code{statprof-stop}, @code{#f} otherwise."
(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
@@ -397,7 +399,7 @@ Enables traps and debugging as necessary."
(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 '())
(sigaction SIGPROF profile-signal-handler)
#t)
@@ -531,7 +533,7 @@ optional @var{port} argument is passed, uses the current output port."
(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
@@ -701,3 +703,82 @@ default: @code{#f}
#: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))))