X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/e1138ba1995f970083ad752f1ff8f71876483194..bbc2364a3e15fd4c7bbaf2c1c41554d7e9a87b9b:/module/statprof.scm diff --git a/module/statprof.scm b/module/statprof.scm index 5a1315b45..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 ;;;; Copyright (C) 2001 Rob Browning ;;;; @@ -159,7 +159,9 @@ statprof-fetch-call-tree statprof - with-statprof)) + with-statprof + + gcprof)) ;; This profiler tracks two numbers for every function called while @@ -214,10 +216,14 @@ (+ 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 @@ -351,7 +357,8 @@ than @code{statprof-stop}, @code{#f} otherwise." 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))) @@ -366,15 +373,16 @@ than @code{statprof-stop}, @code{#f} otherwise." (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 @@ -391,9 +399,8 @@ 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 '()) - (debug-enable 'debug) (sigaction SIGPROF profile-signal-handler) #t) @@ -526,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 @@ -571,23 +578,13 @@ to @code{statprof-reset} is true." 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*) @@ -706,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))))