mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

statprof and gcprof procedures use a fresh statprof state

Browse source 
* module/statprof.scm (statprof, gcprof): Create a fresh statprof
  state.
This commit is contained in:
Andy Wingo 2014-02-25 22:16:49 +01:00
parent 4b3d7a2b7c
commit fd5dfcce80
1 changed files with 76 additions and 77 deletions
Download patch file Download diff file Expand all files Collapse all files

153
module/statprof.scm
View file

@ -658,25 +658,24 @@ 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 whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
@code{statprof-fetch-call-tree} to retrieve the last-stored stacks." @code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
(define state (ensure-profiler-state)) (let ((state (fresh-profiler-state)))
(parameterize ((profiler-state state))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(statprof-reset (inexact->exact (floor (/ 1 hz))) (statprof-reset (inexact->exact (floor (/ 1 hz)))
(inexact->exact (* 1e6 (- (/ 1 hz) (inexact->exact (* 1e6 (- (/ 1 hz)
(floor (/ 1 hz))))) (floor (/ 1 hz)))))
count-calls? count-calls?
full-stacks?) full-stacks?)
(statprof-start)) (statprof-start))
(lambda () (lambda ()
(let lp ((i loop)) (let lp ((i loop))
(unless (zero? i) (unless (zero? i)
(thunk) (thunk)
(lp (1- i))))) (lp (1- i)))))
(lambda () (lambda ()
(statprof-stop) (statprof-stop)
(statprof-display) (statprof-display))))))
(set-procedure-data! state #f))))
(define-macro (with-statprof . args) (define-macro (with-statprof . args)
"Profiles the expressions in its body. "Profiles the expressions in its body.
@ -732,68 +731,68 @@ 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 whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
@code{statprof-fetch-call-tree} to retrieve the last-stored stacks." @code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
(define state (ensure-profiler-state)) (let ((state (fresh-profiler-state)))
(parameterize ((profiler-state state))
(define (reset) (define (reset)
(when (positive? (profile-level state)) (when (positive? (profile-level state))
(error "Can't reset profiler while profiler is running.")) (error "Can't reset profiler while profiler is running."))
(set-accumulated-time! state 0) (set-accumulated-time! state 0)
(set-last-start-time! state #f) (set-last-start-time! state #f)
(set-sample-count! state 0) (set-sample-count! state 0)
(set-count-calls?! state #f) (set-count-calls?! state #f)
(set-procedure-data! state (make-hash-table 131)) (set-procedure-data! state (make-hash-table 131))
(set-record-full-stacks?! state full-stacks?) (set-record-full-stacks?! state full-stacks?)
(set-stacks! state '())) (set-stacks! state '()))
(define (gc-callback) (define (gc-callback)
(cond (cond
((inside-profiler? state)) ((inside-profiler? state))
(else (else
(set-inside-profiler?! state #t) (set-inside-profiler?! state #t)
;; FIXME: should be able to set an outer frame for the stack cut ;; FIXME: should be able to set an outer frame for the stack cut
(let ((stop-time (get-internal-run-time)) (let ((stop-time (get-internal-run-time))
;; Cut down to gc-callback, and then one before (the ;; Cut down to gc-callback, and then one before (the
;; after-gc async). See the note in profile-signal-handler ;; after-gc async). See the note in profile-signal-handler
;; also. ;; also.
(stack (or (make-stack #t gc-callback 0 1) (stack (or (make-stack #t gc-callback 0 1)
(pk 'what! (make-stack #t))))) (pk 'what! (make-stack #t)))))
(sample-stack-procs state stack) (sample-stack-procs state stack)
(accumulate-time state stop-time) (accumulate-time state stop-time)
(set-last-start-time! state (get-internal-run-time))) (set-last-start-time! state (get-internal-run-time)))
(set-inside-profiler?! state #f)))) (set-inside-profiler?! state #f))))
(define (start) (define (start)
(set-profile-level! state (+ (profile-level state) 1)) (set-profile-level! state (+ (profile-level state) 1))
(when (= (profile-level state) 1) (when (= (profile-level state) 1)
(set-remaining-prof-time! state #f) (set-remaining-prof-time! state #f)
(set-last-start-time! state (get-internal-run-time)) (set-last-start-time! state (get-internal-run-time))
(set-gc-time-taken! state (assq-ref (gc-stats) 'gc-time-taken)) (set-gc-time-taken! state (assq-ref (gc-stats) 'gc-time-taken))
(add-hook! after-gc-hook gc-callback) (add-hook! after-gc-hook gc-callback)
(set-vm-trace-level! (1+ (vm-trace-level))) (set-vm-trace-level! (1+ (vm-trace-level)))
#t)) #t))
(define (stop) (define (stop)
(set-profile-level! state (- (profile-level state) 1)) (set-profile-level! state (- (profile-level state) 1))
(when (zero? (profile-level state)) (when (zero? (profile-level state))
(set-gc-time-taken! state (set-gc-time-taken! state
(- (assq-ref (gc-stats) 'gc-time-taken) (- (assq-ref (gc-stats) 'gc-time-taken)
(gc-time-taken state))) (gc-time-taken state)))
(remove-hook! after-gc-hook gc-callback) (remove-hook! after-gc-hook gc-callback)
(accumulate-time state (get-internal-run-time)) (accumulate-time state (get-internal-run-time))
(set-last-start-time! state #f))) (set-last-start-time! state #f)))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(reset) (reset)
(start)) (start))
(lambda () (lambda ()
(let lp ((i loop)) (let lp ((i loop))
(unless (zero? i) (unless (zero? i)
(thunk) (thunk)
(lp (1- i))))) (lp (1- i)))))
(lambda () (lambda ()
(stop) (stop)
(statprof-display) (statprof-display))))))
(set-procedure-data! state #f))))