;;;; (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>
;;;;
statprof-call-data->stats
statprof-stats-proc-name
+ statprof-stats-proc-source
statprof-stats-%-time-in-proc
statprof-stats-cum-secs-in-proc
statprof-stats-self-secs-in-proc
gcprof))
-;; This profiler tracks two numbers for every function called while
-;; it's active. It tracks the total number of calls, and the number
-;; of times the function was active when the sampler fired.
-;;
-;; Globally the profiler tracks the total time elapsed and the number
-;; of times the sampler was fired.
-;;
-;; Right now, this profiler is not per-thread and is not thread safe.
+;;; ~ Implementation notes ~
+;;;
+;;; Statprof can be divided into two pieces: data collection and data
+;;; analysis.
+;;;
+;;; The data collection runs concurrently with the program, and is
+;;; designed to be as cheap as possible. The main data collection
+;;; instrument is the stack sampler, driven by SIGPROF signals that are
+;;; scheduled with periodic setitimer calls. The stack sampler simply
+;;; looks at every frame on the stack, and writes a representation of
+;;; the frame's procedure into a growable buffer.
+;;;
+;;; For most frames, this representation is the instruction pointer of
+;;; that frame, because it's cheap to get and you can map from
+;;; instruction pointer to procedure fairly cheaply. This won't
+;;; distinguish between different closures which share the same code,
+;;; but that is usually what we want anyway.
+;;;
+;;; One case in which we do want to distinguish closures is the case of
+;;; primitive procedures. If slot 0 in the frame is a primitive
+;;; procedure, we record the procedure's name into the buffer instead of
+;;; the IP. It's fairly cheap to check whether a value is a primitive
+;;; procedure, and then get its name, as its name is stored in the
+;;; closure data. Calling procedure-name in the stack sampler isn't
+;;; something you want to do for other kinds of procedures, though, as
+;;; that involves grovelling the debug information.
+;;;
+;;; The other part of data collection is the exact call counter, which
+;;; uses the VM's "apply" hook to record each procedure call.
+;;; Naturally, this is quite expensive, and it is off by default.
+;;; Running code at every procedure call effectively penalizes procedure
+;;; calls. Still, it's useful sometimes. If the profiler state has a
+;;; call-counts table, then calls will be counted. As with the stack
+;;; counter, usually the key in the hash table is the code pointer of
+;;; the procedure being called, except for primitive procedures, in
+;;; which case it is the name of the primitive. The call counter can
+;;; also see calls of non-programs, for example in the case of
+;;; applicable structs. In that case the key is the procedure itself.
+;;;
+;;; After collection is finished, the data can be analyzed. The first
+;;; step is usually to run over the stack traces, tabulating sample
+;;; counts by procedure; the stack-samples->procedure-data does that.
+;;; The result of stack-samples->procedure-data is a hash table mapping
+;;; procedures to "call data" records. The call data values are exposed
+;;; to users via the statprof-fold-call-data procedure.
+;;;
+;;; Usually all the analysis is triggered by calling statprof-display,
+;;; or having the statprof procedure call it for you.
+;;;
+;;; The other thing we can do is to look at the stacks themselves, for
+;;; example via statprof-fetch-call-tree.
+;;;
+
+;;; ~ Threads and state ~
+;;;
+;;; The state of the profiler is contained in a <state> record, which is
+;;; bound to a thread-local parameter. The accurate call counter uses
+;;; the VM apply hook, which is also local to the current thread, so all
+;;; is good there.
+;;;
+;;; The problem comes in the statistical stack sampler's use of
+;;; `setitimer' and SIGPROF. The timer manipulated by setitimer is a
+;;; whole-process timer, so it decrements as other threads execute,
+;;; which is the wrong thing if you want to profile just one thread. On
+;;; the other hand, SIGPROF is delivered to the process as a whole,
+;;; which is fine given Guile's signal-handling thread, but then only
+;;; delivered to the thread running statprof, which isn't the right
+;;; thing if you want to profile the whole system.
+;;;
+;;; The summary is that statprof works more or less well as a per-thread
+;;; profiler if no other threads are running on their own when
+;;; profiling. If the other threads are running on behalf of the thread
+;;; being profiled (as via futures or parallel marking) things still
+;;; mostly work as expected. You can run statprof in one thread,
+;;; finish, and then run statprof in another thread, and the profile
+;;; runs won't affect each other. But if you want true per-thread
+;;; profiles when other things are happening in the process, including
+;;; other statprof runs, or whole-process profiles with per-thread
+;;; breakdowns, the use of setitimer currently prevents that.
+;;;
+;;; The solution would be to switch to POSIX.1-2001's timer_create(2),
+;;; and to add some more threading-related API to statprof. Some other
+;;; day.
+;;;
(define-record-type <state>
(make-state accumulated-time last-start-time sample-count
sampling-period remaining-prof-time profile-level
call-counts gc-time-taken inside-profiler?
- prev-sigprof-handler buffer buffer-pos)
+ prev-sigprof-handler outer-cut buffer buffer-pos)
state?
;; Total time so far.
(accumulated-time accumulated-time set-accumulated-time!)
(gc-time-taken gc-time-taken set-gc-time-taken!)
;; True if we are inside the profiler.
(inside-profiler? inside-profiler? set-inside-profiler?!)
- ;; True if we are inside the profiler.
+ ;; Previous sigprof handler.
(prev-sigprof-handler prev-sigprof-handler set-prev-sigprof-handler!)
+ ;; Outer stack cut, or 0.
+ (outer-cut outer-cut)
;; Stack samples.
(buffer buffer set-buffer!)
(buffer-pos buffer-pos set-buffer-pos!))
new))
(define* (fresh-profiler-state #:key (count-calls? #f)
- (sampling-period 10000))
+ (sampling-period 10000)
+ (outer-cut 0))
(make-state 0 #f 0
sampling-period 0 0
(and count-calls? (make-hash-table)) 0 #f
- #f (fresh-buffer) 0))
+ #f outer-cut (fresh-buffer) 0))
(define (ensure-profiler-state)
(or (profiler-state)
(set-sample-count! state (+ (sample-count state) 1))
(let lp ((frame (stack-ref stack 0))
+ (len (stack-length stack))
(buffer (buffer state))
(pos (buffer-pos state)))
(define (write-sample sample)
(vector-set! buffer pos sample))
(define (continue pos)
- (lp (frame-previous frame) buffer pos))
+ (lp (frame-previous frame) (1- len) buffer pos))
(define (write-sample-and-continue sample)
(write-sample sample)
(continue (1+ pos)))
(cond
((= pos (vector-length buffer))
- (lp frame (expand-buffer buffer) pos))
- ((not frame)
+ (lp frame len (expand-buffer buffer) pos))
+ ((or (zero? len) (not frame))
(write-sample #f)
(set-buffer! state buffer)
(set-buffer-pos! state (1+ pos)))
(else
(let ((proc (frame-procedure frame)))
- (cond
- ((primitive? proc)
- (write-sample-and-continue (procedure-name proc)))
- ((program? proc)
- (write-sample-and-continue (frame-instruction-pointer frame)))
- (proc (write-sample-and-continue proc))
- ;; If proc is false, that would confuse our stack walker.
- ;; Ignore it.
- (else (continue pos))))))))
+ (write-sample-and-continue (if (primitive? proc)
+ (procedure-name proc)
+ (frame-instruction-pointer frame))))))))
(define (reset-sigprof-timer usecs)
;; Guile's setitimer binding is terrible.
(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)
-
- ;; FIXME: with-statprof should be able to set an outer frame for the
- ;; stack cut
- (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)
- (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))
(values))
(define-record-type call-data
- (make-call-data name source printable
+ (make-call-data name printable source
call-count cum-sample-count self-sample-count)
call-data?
(name call-data-name)
- (source call-data-source)
(printable call-data-printable)
+ (source call-data-source)
(call-count call-data-call-count set-call-data-call-count!)
(cum-sample-count call-data-cum-sample-count set-call-data-cum-sample-count!)
(self-sample-count call-data-self-sample-count set-call-data-self-sample-count!))
data))))
(define (addr->printable addr pdi)
- (if pdi
- (program-debug-info-printable pdi)
- (string-append "#x" (number->string addr 16))))
+ (or (and=> (and=> pdi program-debug-info-name) symbol->string)
+ (string-append "anon #x" (number->string addr 16))))
(define (inc-call-data-cum-sample-count! cd)
(set-call-data-cum-sample-count! cd (1+ (call-data-cum-sample-count cd))))
(entry (if pdi (program-debug-info-addr pdi) addr)))
(or (hashv-ref table entry)
(let ((data (make-call-data (and=> pdi program-debug-info-name)
- (find-source-for-addr entry)
(addr->printable entry pdi)
+ (find-source-for-addr entry)
(and call-counts
(hashv-ref call-counts entry))
0
;; a primitive
((symbol? callee) callee)
(else #f))
- #f
(with-output-to-string (lambda () (write callee)))
+ #f
(and call-counts (hashv-ref call-counts callee))
0
0)))
(visit-stacks (1+ pos) (cons (reverse stack) out))))))
(else (reverse out))))))
-(define (statprof-fold-call-data proc init)
+(define* (statprof-fold-call-data proc init #:optional
+ (state (existing-profiler-state)))
"Fold @var{proc} over the call-data accumulated by statprof. Cannot be
called while statprof is active. @var{proc} should take two arguments,
@code{(@var{call-data} @var{prior-result})}.
(lambda (key value prior-result)
(proc value prior-result))
init
- (stack-samples->procedure-data (existing-profiler-state))))
+ (stack-samples->procedure-data state)))
-(define (statprof-proc-call-data proc)
+(define* (statprof-proc-call-data proc #:optional
+ (state (existing-profiler-state)))
"Returns the call-data associated with @var{proc}, or @code{#f} if
none is available."
(when (statprof-active?)
(error "Can't call statprof-proc-call-data while profiler is running."))
- (hashv-ref (stack-samples->procedure-data (existing-profiler-state))
+ (hashv-ref (stack-samples->procedure-data state)
(cond
((primitive? proc) (procedure-name proc))
((program? proc) (program-code proc))
;; Stats
(define-record-type stats
- (make-stats proc-name %-time-in-proc cum-secs-in-proc self-secs-in-proc
+ (make-stats proc-name proc-source
+ %-time-in-proc cum-secs-in-proc self-secs-in-proc
calls self-secs-per-call cum-secs-per-call)
stats?
(proc-name statprof-stats-proc-name)
+ (proc-source statprof-stats-proc-source)
(%-time-in-proc statprof-stats-%-time-in-proc)
(cum-secs-in-proc statprof-stats-cum-secs-in-proc)
(self-secs-in-proc statprof-stats-self-secs-in-proc)
"Returns an object of type @code{statprof-stats}."
(define state (existing-profiler-state))
- (let* ((proc-name (call-data-printable call-data))
+ (let* ((proc-name (call-data-name call-data))
+ (proc-source (and=> (call-data-source call-data) source->string))
(self-samples (call-data-self-sample-count call-data))
(cum-samples (call-data-cum-sample-count call-data))
- (all-samples (statprof-sample-count))
- (secs-per-sample (/ (statprof-accumulated-time)
- (statprof-sample-count)))
+ (all-samples (statprof-sample-count state))
+ (secs-per-sample (/ (statprof-accumulated-time state)
+ (statprof-sample-count state)))
(num-calls (and (call-counts state)
(statprof-call-data-calls call-data))))
- (make-stats proc-name
+ (make-stats (or proc-name
+ ;; If there is no name and no source, fall back to
+ ;; printable.
+ (and (not proc-source) (call-data-printable call-data)))
+ proc-source
(* (/ self-samples all-samples) 100.0)
(* cum-samples secs-per-sample 1.0)
(* self-samples secs-per-sample 1.0)
"Displays a gprof-like summary of the statistics collected. Unless an
optional @var{port} argument is passed, uses the current output port."
(cond
- ((zero? (statprof-sample-count))
+ ((zero? (statprof-sample-count state))
(format port "No samples recorded.\n"))
(else
(let* ((stats-list (statprof-fold-call-data
(lambda (data prior-value)
(cons (statprof-call-data->stats data)
prior-value))
- '()))
+ '()
+ state))
(sorted-stats (sort stats-list stats-sorter)))
(define (display-stats-line stats)
(* 1000 (statprof-stats-cum-secs-per-call stats)))
(format port " "))
(display " " port))
- (display (statprof-stats-proc-name stats) port)
- (newline port))
+ (let ((source (statprof-stats-proc-source stats))
+ (name (statprof-stats-proc-name stats)))
+ (when source
+ (display source port)
+ (when name
+ (display ":" port)))
+ (when name
+ (display name port))
+ (newline port)))
(if (call-counts state)
(begin
(format port "~5a ~10a ~7a ~8a ~8a ~8a ~8@a\n"
"% " "cumulative" "self" "" "self" "total" "")
- (format port "~5a ~9a ~8a ~8a ~8a ~8a ~8@a\n"
- "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "name"))
+ (format port "~5a ~9a ~8a ~8a ~8a ~8a ~a\n"
+ "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "procedure"))
(begin
- (format port "~5a ~10a ~7a ~8@a\n"
+ (format port "~5a ~10a ~7a ~8a\n"
"%" "cumulative" "self" "")
- (format port "~5a ~10a ~7a ~8@a\n"
- "time" "seconds" "seconds" "name")))
+ (format port "~5a ~10a ~7a ~a\n"
+ "time" "seconds" "seconds" "procedure")))
(for-each display-stats-line sorted-stats)
(display "---\n" port)
- (simple-format #t "Sample count: ~A\n" (statprof-sample-count))
+ (simple-format #t "Sample count: ~A\n" (statprof-sample-count state))
(simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
- (statprof-accumulated-time)
+ (statprof-accumulated-time state)
(/ (gc-time-taken state)
1.0 internal-time-units-per-second))))))
(call-data-name data)
(call-data-call-count data)
(call-data-cum-sample-count data))))
- #f)
- (simple-format #t "Total time: ~A\n" (statprof-accumulated-time))
- (simple-format #t "Sample count: ~A\n" (statprof-sample-count)))
+ #f
+ state)
+ (simple-format #t "Total time: ~A\n" (statprof-accumulated-time state))
+ (simple-format #t "Sample count: ~A\n" (statprof-sample-count state)))
(define (statprof-display-anomolies)
(issue-deprecation-warning "statprof-display-anomolies is a misspelling. "
(stack-samples->callee-lists state))
equal?))))
+(define (call-thunk thunk)
+ (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))))))
+ (inexact->exact (round (/ 1e6 hz)))
+ #: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)
- (thunk)
- (lp (1- i)))))
+ (unless (= i 1)
+ (call-thunk thunk)
+ (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:
#: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?)
+(define* (gcprof thunk #:key (loop 1) full-stacks? (port (current-output-port)))
"Do an allocation profile of the execution of @var{thunk}.
The stack will be sampled soon after every garbage collection, yielding
@var{loop} parameter, to cause @var{thunk} to be called @var{loop}
times."
- (let ((state (fresh-profiler-state)))
+ (let ((state (fresh-profiler-state #:outer-cut
+ (program-address-range call-thunk))))
(parameterize ((profiler-state state))
(define (gc-callback)
(unless (inside-profiler? state)
(set-inside-profiler?! state #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)
+ (stack (or (make-stack #t gc-callback (outer-cut state) 1)
(pk 'what! (make-stack #t)))))
(sample-stack-procs state stack)
(accumulate-time state stop-time)
(lambda ()
(let lp ((i loop))
(unless (zero? i)
- (thunk)
+ (call-thunk thunk)
(lp (1- i)))))
(lambda ()
(remove-hook! after-gc-hook gc-callback)
(gc-time-taken state)))
(accumulate-time state (get-internal-run-time))
(set-profile-level! state 0)
- (statprof-display))))))
+ (statprof-display port state))))))
HCoop / bpt / guile.git / blobdiff