;;;; (statprof) -- a statistical profiler for Guile
;;;; -*-scheme-*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2013-2015 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>
;;;;
(let ((prev (setitimer ITIMER_PROF 0 0 0 usecs)))
(+ (* (caadr prev) #e1e6) (cdadr prev))))
-(define (profile-signal-handler sig)
- (define state (existing-profiler-state))
+(define profile-signal-handler
+ (let ()
+ (define (profile-signal-handler sig)
+ (define state (existing-profiler-state))
+
+ (set-inside-profiler?! state #t)
+
+ (when (positive? (profile-level state))
+ (let* ((stop-time (get-internal-run-time))
+ ;; Cut down to the signal handler. Note that this will
+ ;; only work if statprof.scm is compiled; otherwise we
+ ;; get `eval' on the stack instead, because if it's not
+ ;; compiled, profile-signal-handler is a thunk that
+ ;; tail-calls eval. For the same reason we define the
+ ;; handler in an inner letrec, so that the compiler sees
+ ;; the inner reference to profile-signal-handler as the
+ ;; same as the procedure, and therefore keeps slot 0
+ ;; alive. Nastiness, that.
+ (stack
+ (or (make-stack #t profile-signal-handler (outer-cut state))
+ (pk 'what! (make-stack #t)))))
+
+ (sample-stack-procs state stack)
+ (accumulate-time state stop-time)
+ (set-last-start-time! state (get-internal-run-time))
- (set-inside-profiler?! state #t)
-
- (when (positive? (profile-level state))
- (let* ((stop-time (get-internal-run-time))
- ;; Cut down to the signal handler. Note that this will only
- ;; work if statprof.scm is compiled; otherwise we get `eval'
- ;; on the stack instead, because if it's not compiled,
- ;; profile-signal-handler is a thunk that tail-calls eval.
- ;; Perhaps we should always compile the signal handler
- ;; instead.
- (stack (or (make-stack #t profile-signal-handler (outer-cut state))
- (pk 'what! (make-stack #t)))))
-
- (sample-stack-procs state stack)
- (accumulate-time state stop-time)
- (set-last-start-time! state (get-internal-run-time))
+ (reset-sigprof-timer (sampling-period state))))
- (reset-sigprof-timer (sampling-period state))))
-
- (set-inside-profiler?! state #f))
+ (set-inside-profiler?! state #f))
+ profile-signal-handler))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Count total calls.
(set-prev-sigprof-handler! state (car prev)))
(reset-sigprof-timer (if (zero? rpt) (sampling-period state) rpt))
(when (call-counts state)
- (add-hook! (vm-apply-hook) count-call))
- (set-vm-trace-level! (1+ (vm-trace-level)))
+ (add-hook! (vm-apply-hook) count-call)
+ (set-vm-trace-level! (1+ (vm-trace-level))))
#t)))
;; Do not call this from statprof internal functions -- user only.
;; signals here, but if I'm wrong, please let me know.
(set-profile-level! state (- (profile-level state) 1))
(when (zero? (profile-level state))
+ (when (call-counts state)
+ (set-vm-trace-level! (1- (vm-trace-level)))
+ (remove-hook! (vm-apply-hook) count-call))
(set-gc-time-taken! state
(- (assq-ref (gc-stats) 'gc-time-taken)
(gc-time-taken state)))
- (set-vm-trace-level! (1- (vm-trace-level)))
- (when (call-counts state)
- (remove-hook! (vm-apply-hook) 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! state (reset-sigprof-timer 0))
equal?))))
(define (call-thunk thunk)
- (thunk)
- (values))
+ (call-with-values (lambda () (thunk))
+ (lambda results
+ (apply values results))))
(define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f)
(port (current-output-port)) full-stacks?)
- "Profiles the execution of @var{thunk}.
+ "Profile the execution of @var{thunk}, and return its return values.
-The stack will be sampled @var{hz} times per second, and the thunk itself will
-be called @var{loop} times.
+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."
(let ((state (fresh-profiler-state #:count-calls? count-calls?
#:sampling-period
(inexact->exact (round (/ 1e6 hz)))
- #:outer-cut call-thunk)))
+ #:outer-cut
+ (program-address-range call-thunk))))
(parameterize ((profiler-state state))
(dynamic-wind
(lambda ()
(statprof-start state))
(lambda ()
(let lp ((i loop))
- (unless (zero? i)
+ (unless (= i 1)
(call-thunk thunk)
- (lp (1- i)))))
+ (lp (1- i))))
+ (call-thunk thunk))
(lambda ()
(statprof-stop state)
(statprof-display port state))))))
(define-macro (with-statprof . args)
- "Profiles the expressions in its body.
+ "Profile the expressions in the body, and return the body's return values.
Keyword arguments:
@var{loop} parameter, to cause @var{thunk} to be called @var{loop}
times."
- (let ((state (fresh-profiler-state #:outer-cut call-thunk)))
+ (let ((state (fresh-profiler-state #:outer-cut
+ (program-address-range call-thunk))))
(parameterize ((profiler-state state))
(define (gc-callback)
(unless (inside-profiler? state)
HCoop / bpt / guile.git / blobdiff