Commit | Line | Data |
---|---|---|
47f3ce52 AW |
1 | ;;;; (statprof) -- a statistical profiler for Guile |
2 | ;;;; -*-scheme-*- | |
3 | ;;;; | |
e1138ba1 | 4 | ;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. |
47f3ce52 AW |
5 | ;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com> |
6 | ;;;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org> | |
7 | ;;;; | |
8 | ;;;; This library is free software; you can redistribute it and/or | |
9 | ;;;; modify it under the terms of the GNU Lesser General Public | |
10 | ;;;; License as published by the Free Software Foundation; either | |
11 | ;;;; version 3 of the License, or (at your option) any later version. | |
12 | ;;;; | |
13 | ;;;; This library is distributed in the hope that it will be useful, | |
14 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
16 | ;;;; Lesser General Public License for more details. | |
17 | ;;;; | |
18 | ;;;; You should have received a copy of the GNU Lesser General Public | |
19 | ;;;; License along with this library; if not, write to the Free Software | |
20 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
21 | ;;;; | |
22 | \f | |
23 | ||
24 | ;;; Commentary: | |
25 | ;; | |
26 | ;;@code{(statprof)} is intended to be a fairly simple | |
27 | ;;statistical profiler for guile. It is in the early stages yet, so | |
28 | ;;consider its output still suspect, and please report any bugs to | |
29 | ;;@email{guile-devel at gnu.org}, or to me directly at @email{rlb at | |
30 | ;;defaultvalue.org}. | |
31 | ;; | |
32 | ;;A simple use of statprof would look like this: | |
33 | ;; | |
34 | ;;@example | |
35 | ;; (statprof-reset 0 50000 #t) | |
36 | ;; (statprof-start) | |
37 | ;; (do-something) | |
38 | ;; (statprof-stop) | |
39 | ;; (statprof-display) | |
40 | ;;@end example | |
41 | ;; | |
42 | ;;This would reset statprof, clearing all accumulated statistics, then | |
43 | ;;start profiling, run some code, stop profiling, and finally display a | |
44 | ;;gprof flat-style table of statistics which will look something like | |
45 | ;;this: | |
46 | ;; | |
47 | ;;@example | |
48 | ;; % cumulative self self total | |
49 | ;; time seconds seconds calls ms/call ms/call name | |
50 | ;; 35.29 0.23 0.23 2002 0.11 0.11 - | |
51 | ;; 23.53 0.15 0.15 2001 0.08 0.08 positive? | |
52 | ;; 23.53 0.15 0.15 2000 0.08 0.08 + | |
53 | ;; 11.76 0.23 0.08 2000 0.04 0.11 do-nothing | |
54 | ;; 5.88 0.64 0.04 2001 0.02 0.32 loop | |
55 | ;; 0.00 0.15 0.00 1 0.00 150.59 do-something | |
56 | ;; ... | |
57 | ;;@end example | |
58 | ;; | |
59 | ;;All of the numerical data with the exception of the calls column is | |
60 | ;;statistically approximate. In the following column descriptions, and | |
61 | ;;in all of statprof, "time" refers to execution time (both user and | |
62 | ;;system), not wall clock time. | |
63 | ;; | |
64 | ;;@table @asis | |
65 | ;;@item % time | |
66 | ;;The percent of the time spent inside the procedure itself | |
67 | ;;(not counting children). | |
68 | ;;@item cumulative seconds | |
69 | ;;The total number of seconds spent in the procedure, including | |
70 | ;;children. | |
71 | ;;@item self seconds | |
72 | ;;The total number of seconds spent in the procedure itself (not counting | |
73 | ;;children). | |
74 | ;;@item calls | |
75 | ;;The total number of times the procedure was called. | |
76 | ;;@item self ms/call | |
77 | ;;The average time taken by the procedure itself on each call, in ms. | |
78 | ;;@item total ms/call | |
79 | ;;The average time taken by each call to the procedure, including time | |
80 | ;;spent in child functions. | |
81 | ;;@item name | |
82 | ;;The name of the procedure. | |
83 | ;;@end table | |
84 | ;; | |
85 | ;;The profiler uses @code{eq?} and the procedure object itself to | |
86 | ;;identify the procedures, so it won't confuse different procedures with | |
87 | ;;the same name. They will show up as two different rows in the output. | |
88 | ;; | |
89 | ;;Right now the profiler is quite simplistic. I cannot provide | |
90 | ;;call-graphs or other higher level information. What you see in the | |
91 | ;;table is pretty much all there is. Patches are welcome :-) | |
92 | ;; | |
93 | ;;@section Implementation notes | |
94 | ;; | |
95 | ;;The profiler works by setting the unix profiling signal | |
96 | ;;@code{ITIMER_PROF} to go off after the interval you define in the call | |
97 | ;;to @code{statprof-reset}. When the signal fires, a sampling routine is | |
98 | ;;run which looks at the current procedure that's executing, and then | |
99 | ;;crawls up the stack, and for each procedure encountered, increments | |
100 | ;;that procedure's sample count. Note that if a procedure is encountered | |
101 | ;;multiple times on a given stack, it is only counted once. After the | |
102 | ;;sampling is complete, the profiler resets profiling timer to fire | |
103 | ;;again after the appropriate interval. | |
104 | ;; | |
105 | ;;Meanwhile, the profiler keeps track, via @code{get-internal-run-time}, | |
106 | ;;how much CPU time (system and user -- which is also what | |
107 | ;;@code{ITIMER_PROF} tracks), has elapsed while code has been executing | |
108 | ;;within a statprof-start/stop block. | |
109 | ;; | |
110 | ;;The profiler also tries to avoid counting or timing its own code as | |
111 | ;;much as possible. | |
112 | ;; | |
113 | ;;; Code: | |
114 | ||
115 | ;; When you add new features, please also add tests to ./tests/ if you | |
116 | ;; have time, and then add the new files to ./run-tests. Also, if | |
117 | ;; anyone's bored, there are a lot of existing API bits that don't | |
118 | ;; have tests yet. | |
119 | ||
120 | ;; TODO | |
121 | ;; | |
122 | ;; Check about profiling C functions -- does profiling primitives work? | |
123 | ;; Also look into stealing code from qprof so we can sample the C stack | |
124 | ;; Call graphs? | |
125 | ||
126 | (define-module (statprof) | |
127 | #:use-module (srfi srfi-1) | |
128 | #:autoload (ice-9 format) (format) | |
e1138ba1 AW |
129 | #:use-module (system vm vm) |
130 | #:use-module (system vm frame) | |
131 | #:use-module (system vm program) | |
47f3ce52 AW |
132 | #:export (statprof-active? |
133 | statprof-start | |
134 | statprof-stop | |
135 | statprof-reset | |
136 | ||
137 | statprof-accumulated-time | |
138 | statprof-sample-count | |
139 | statprof-fold-call-data | |
140 | statprof-proc-call-data | |
141 | statprof-call-data-name | |
142 | statprof-call-data-calls | |
143 | statprof-call-data-cum-samples | |
144 | statprof-call-data-self-samples | |
145 | statprof-call-data->stats | |
146 | ||
147 | statprof-stats-proc-name | |
148 | statprof-stats-%-time-in-proc | |
149 | statprof-stats-cum-secs-in-proc | |
150 | statprof-stats-self-secs-in-proc | |
151 | statprof-stats-calls | |
152 | statprof-stats-self-secs-per-call | |
153 | statprof-stats-cum-secs-per-call | |
154 | ||
155 | statprof-display | |
156 | statprof-display-anomolies | |
157 | ||
158 | statprof-fetch-stacks | |
159 | statprof-fetch-call-tree | |
160 | ||
e1138ba1 | 161 | statprof |
47f3ce52 AW |
162 | with-statprof)) |
163 | ||
164 | ||
165 | ;; This profiler tracks two numbers for every function called while | |
166 | ;; it's active. It tracks the total number of calls, and the number | |
167 | ;; of times the function was active when the sampler fired. | |
168 | ;; | |
169 | ;; Globally the profiler tracks the total time elapsed and the number | |
170 | ;; of times the sampler was fired. | |
171 | ;; | |
172 | ;; Right now, this profiler is not per-thread and is not thread safe. | |
173 | ||
174 | (define accumulated-time #f) ; total so far. | |
175 | (define last-start-time #f) ; start-time when timer is active. | |
176 | (define sample-count #f) ; total count of sampler calls. | |
177 | (define sampling-frequency #f) ; in (seconds . microseconds) | |
178 | (define remaining-prof-time #f) ; time remaining when prof suspended. | |
179 | (define profile-level 0) ; for user start/stop nesting. | |
180 | (define %count-calls? #t) ; whether to catch apply-frame. | |
181 | (define gc-time-taken 0) ; gc time between statprof-start and | |
182 | ; statprof-stop. | |
183 | (define record-full-stacks? #f) ; if #t, stash away the stacks | |
184 | ; for later analysis. | |
185 | (define stacks '()) | |
186 | ||
187 | ;; procedure-data will be a hash where the key is the function object | |
188 | ;; itself and the value is the data. The data will be a vector like | |
189 | ;; this: #(name call-count cum-sample-count self-sample-count) | |
190 | (define procedure-data #f) | |
191 | ||
192 | ;; If you change the call-data data structure, you need to also change | |
193 | ;; sample-uncount-frame. | |
c165c50d AW |
194 | (define (make-call-data proc call-count cum-sample-count self-sample-count) |
195 | (vector proc call-count cum-sample-count self-sample-count)) | |
196 | (define (call-data-proc cd) (vector-ref cd 0)) | |
197 | (define (call-data-name cd) (procedure-name (call-data-proc cd))) | |
198 | (define (call-data-printable cd) | |
199 | (or (call-data-name cd) | |
200 | (with-output-to-string (lambda () (write (call-data-proc cd)))))) | |
47f3ce52 AW |
201 | (define (call-data-call-count cd) (vector-ref cd 1)) |
202 | (define (call-data-cum-sample-count cd) (vector-ref cd 2)) | |
203 | (define (call-data-self-sample-count cd) (vector-ref cd 3)) | |
204 | ||
47f3ce52 AW |
205 | (define (inc-call-data-call-count! cd) |
206 | (vector-set! cd 1 (1+ (vector-ref cd 1)))) | |
207 | (define (inc-call-data-cum-sample-count! cd) | |
208 | (vector-set! cd 2 (1+ (vector-ref cd 2)))) | |
209 | (define (inc-call-data-self-sample-count! cd) | |
210 | (vector-set! cd 3 (1+ (vector-ref cd 3)))) | |
211 | ||
212 | (define-macro (accumulate-time stop-time) | |
213 | `(set! accumulated-time | |
214 | (+ accumulated-time 0.0 (- ,stop-time last-start-time)))) | |
215 | ||
216 | (define (get-call-data proc) | |
217 | (or (hashq-ref procedure-data proc) | |
c165c50d | 218 | (let ((call-data (make-call-data proc 0 0 0))) |
47f3ce52 AW |
219 | (hashq-set! procedure-data proc call-data) |
220 | call-data))) | |
221 | ||
222 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
223 | ;; SIGPROF handler | |
224 | ||
225 | (define (sample-stack-procs stack) | |
226 | (let ((stacklen (stack-length stack)) | |
227 | (hit-count-call? #f)) | |
228 | ||
229 | (if record-full-stacks? | |
230 | (set! stacks (cons stack stacks))) | |
231 | ||
232 | (set! sample-count (+ sample-count 1)) | |
233 | ;; Now accumulate stats for the whole stack. | |
234 | (let loop ((frame (stack-ref stack 0)) | |
235 | (procs-seen (make-hash-table 13)) | |
236 | (self #f)) | |
237 | (cond | |
238 | ((not frame) | |
239 | (hash-fold | |
240 | (lambda (proc val accum) | |
241 | (inc-call-data-cum-sample-count! | |
242 | (get-call-data proc))) | |
243 | #f | |
244 | procs-seen) | |
245 | (and=> (and=> self get-call-data) | |
246 | inc-call-data-self-sample-count!)) | |
247 | ((frame-procedure frame) | |
248 | => (lambda (proc) | |
249 | (cond | |
250 | ((eq? proc count-call) | |
251 | ;; We're not supposed to be sampling count-call and | |
252 | ;; its sub-functions, so loop again with a clean | |
253 | ;; slate. | |
254 | (set! hit-count-call? #t) | |
255 | (loop (frame-previous frame) (make-hash-table 13) #f)) | |
c165c50d | 256 | (else |
47f3ce52 AW |
257 | (hashq-set! procs-seen proc #t) |
258 | (loop (frame-previous frame) | |
259 | procs-seen | |
c165c50d | 260 | (or self proc)))))) |
47f3ce52 AW |
261 | (else |
262 | (loop (frame-previous frame) procs-seen self)))) | |
263 | hit-count-call?)) | |
264 | ||
265 | (define inside-profiler? #f) | |
266 | ||
267 | (define (profile-signal-handler sig) | |
268 | (set! inside-profiler? #t) | |
269 | ||
270 | ;; FIXME: with-statprof should be able to set an outer frame for the | |
271 | ;; stack cut | |
272 | (if (positive? profile-level) | |
273 | (let* ((stop-time (get-internal-run-time)) | |
c165c50d AW |
274 | ;; cut down to the signal handler. note that this will only |
275 | ;; work if statprof.scm is compiled; otherwise we get | |
276 | ;; `eval' on the stack instead, because if it's not | |
277 | ;; compiled, profile-signal-handler is a thunk that | |
278 | ;; tail-calls eval. perhaps we should always compile the | |
279 | ;; signal handler instead... | |
280 | (stack (or (make-stack #t profile-signal-handler) | |
281 | (pk 'what! (make-stack #t)))) | |
47f3ce52 AW |
282 | (inside-apply-trap? (sample-stack-procs stack))) |
283 | ||
284 | (if (not inside-apply-trap?) | |
285 | (begin | |
286 | ;; disabling here is just a little more efficient, but | |
287 | ;; not necessary given inside-profiler?. We can't just | |
288 | ;; disable unconditionally at the top of this function | |
289 | ;; and eliminate inside-profiler? because it seems to | |
290 | ;; confuse guile wrt re-enabling the trap when | |
291 | ;; count-call finishes. | |
e1138ba1 AW |
292 | (if %count-calls? |
293 | (set-vm-trace-level! (the-vm) | |
294 | (1- (vm-trace-level (the-vm))))) | |
47f3ce52 AW |
295 | (accumulate-time stop-time))) |
296 | ||
297 | (setitimer ITIMER_PROF | |
298 | 0 0 | |
299 | (car sampling-frequency) | |
300 | (cdr sampling-frequency)) | |
301 | ||
302 | (if (not inside-apply-trap?) | |
303 | (begin | |
304 | (set! last-start-time (get-internal-run-time)) | |
e1138ba1 AW |
305 | (if %count-calls? |
306 | (set-vm-trace-level! (the-vm) | |
307 | (1+ (vm-trace-level (the-vm))))))))) | |
308 | ||
47f3ce52 AW |
309 | (set! inside-profiler? #f)) |
310 | ||
311 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
312 | ;; Count total calls. | |
313 | ||
e1138ba1 | 314 | (define (count-call frame) |
47f3ce52 AW |
315 | (if (not inside-profiler?) |
316 | (begin | |
317 | (accumulate-time (get-internal-run-time)) | |
318 | ||
e1138ba1 | 319 | (and=> (frame-procedure frame) |
47f3ce52 | 320 | (lambda (proc) |
c165c50d AW |
321 | (inc-call-data-call-count! |
322 | (get-call-data proc)))) | |
47f3ce52 AW |
323 | |
324 | (set! last-start-time (get-internal-run-time))))) | |
325 | ||
326 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
327 | ||
328 | (define (statprof-active?) | |
329 | "Returns @code{#t} if @code{statprof-start} has been called more times | |
330 | than @code{statprof-stop}, @code{#f} otherwise." | |
331 | (positive? profile-level)) | |
332 | ||
333 | ;; Do not call this from statprof internal functions -- user only. | |
334 | (define (statprof-start) | |
335 | "Start the profiler.@code{}" | |
336 | ;; After some head-scratching, I don't *think* I need to mask/unmask | |
337 | ;; signals here, but if I'm wrong, please let me know. | |
338 | (set! profile-level (+ profile-level 1)) | |
339 | (if (= profile-level 1) | |
340 | (let* ((rpt remaining-prof-time) | |
341 | (use-rpt? (and rpt | |
342 | (or (positive? (car rpt)) | |
343 | (positive? (cdr rpt)))))) | |
344 | (set! remaining-prof-time #f) | |
345 | (set! last-start-time (get-internal-run-time)) | |
346 | (set! gc-time-taken | |
347 | (cdr (assq 'gc-time-taken (gc-stats)))) | |
348 | (if use-rpt? | |
349 | (setitimer ITIMER_PROF 0 0 (car rpt) (cdr rpt)) | |
350 | (setitimer ITIMER_PROF | |
351 | 0 0 | |
352 | (car sampling-frequency) | |
353 | (cdr sampling-frequency))) | |
e1138ba1 AW |
354 | (add-hook! (vm-apply-hook (the-vm)) count-call) |
355 | (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm)))) | |
47f3ce52 AW |
356 | #t))) |
357 | ||
358 | ;; Do not call this from statprof internal functions -- user only. | |
359 | (define (statprof-stop) | |
360 | "Stop the profiler.@code{}" | |
361 | ;; After some head-scratching, I don't *think* I need to mask/unmask | |
362 | ;; signals here, but if I'm wrong, please let me know. | |
363 | (set! profile-level (- profile-level 1)) | |
364 | (if (zero? profile-level) | |
365 | (begin | |
366 | (set! gc-time-taken | |
367 | (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken)) | |
e1138ba1 AW |
368 | (set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm)))) |
369 | (remove-hook! (vm-apply-hook (the-vm)) count-call) | |
47f3ce52 AW |
370 | ;; I believe that we need to do this before getting the time |
371 | ;; (unless we want to make things even more complicated). | |
372 | (set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0)) | |
373 | (accumulate-time (get-internal-run-time)) | |
374 | (set! last-start-time #f)))) | |
375 | ||
376 | (define (statprof-reset sample-seconds sample-microseconds count-calls? | |
377 | . full-stacks?) | |
378 | "Reset the statprof sampler interval to @var{sample-seconds} and | |
379 | @var{sample-microseconds}. If @var{count-calls?} is true, arrange to | |
380 | instrument procedure calls as well as collecting statistical profiling | |
381 | data. If @var{full-stacks?} is true, collect all sampled stacks into a | |
382 | list for later analysis. | |
383 | ||
384 | Enables traps and debugging as necessary." | |
385 | (if (positive? profile-level) | |
386 | (error "Can't reset profiler while profiler is running.")) | |
387 | (set! %count-calls? count-calls?) | |
388 | (set! accumulated-time 0) | |
389 | (set! last-start-time #f) | |
390 | (set! sample-count 0) | |
391 | (set! sampling-frequency (cons sample-seconds sample-microseconds)) | |
392 | (set! remaining-prof-time #f) | |
393 | (set! procedure-data (make-hash-table 131)) | |
47f3ce52 AW |
394 | (set! record-full-stacks? (and (pair? full-stacks?) (car full-stacks?))) |
395 | (set! stacks '()) | |
396 | (debug-enable 'debug) | |
397 | (sigaction SIGPROF profile-signal-handler) | |
398 | #t) | |
399 | ||
400 | (define (statprof-fold-call-data proc init) | |
401 | "Fold @var{proc} over the call-data accumulated by statprof. Cannot be | |
402 | called while statprof is active. @var{proc} should take two arguments, | |
403 | @code{(@var{call-data} @var{prior-result})}. | |
404 | ||
405 | Note that a given proc-name may appear multiple times, but if it does, | |
406 | it represents different functions with the same name." | |
407 | (if (positive? profile-level) | |
408 | (error "Can't call statprof-fold-called while profiler is running.")) | |
409 | ||
410 | (hash-fold | |
411 | (lambda (key value prior-result) | |
412 | (proc value prior-result)) | |
413 | init | |
414 | procedure-data)) | |
415 | ||
416 | (define (statprof-proc-call-data proc) | |
417 | "Returns the call-data associated with @var{proc}, or @code{#f} if | |
418 | none is available." | |
419 | (if (positive? profile-level) | |
420 | (error "Can't call statprof-fold-called while profiler is running.")) | |
421 | ||
422 | (hashq-ref procedure-data proc)) | |
423 | ||
424 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
425 | ;; Stats | |
426 | ||
427 | (define (statprof-call-data->stats call-data) | |
428 | "Returns an object of type @code{statprof-stats}." | |
429 | ;; returns (vector proc-name | |
430 | ;; %-time-in-proc | |
431 | ;; cum-seconds-in-proc | |
432 | ;; self-seconds-in-proc | |
433 | ;; num-calls | |
434 | ;; self-secs-per-call | |
435 | ;; total-secs-per-call) | |
436 | ||
c165c50d | 437 | (let* ((proc-name (call-data-printable call-data)) |
47f3ce52 AW |
438 | (self-samples (call-data-self-sample-count call-data)) |
439 | (cum-samples (call-data-cum-sample-count call-data)) | |
440 | (all-samples (statprof-sample-count)) | |
441 | (secs-per-sample (/ (statprof-accumulated-time) | |
442 | (statprof-sample-count))) | |
443 | (num-calls (and %count-calls? (statprof-call-data-calls call-data)))) | |
444 | ||
445 | (vector proc-name | |
446 | (* (/ self-samples all-samples) 100.0) | |
447 | (* cum-samples secs-per-sample 1.0) | |
448 | (* self-samples secs-per-sample 1.0) | |
449 | num-calls | |
450 | (and num-calls ;; maybe we only sampled in children | |
451 | (if (zero? self-samples) 0.0 | |
452 | (/ (* self-samples secs-per-sample) 1.0 num-calls))) | |
453 | (and num-calls ;; cum-samples must be positive | |
e1138ba1 AW |
454 | (/ (* cum-samples secs-per-sample) |
455 | 1.0 | |
456 | ;; num-calls might be 0 if we entered statprof during the | |
457 | ;; dynamic extent of the call | |
458 | (max num-calls 1)))))) | |
47f3ce52 AW |
459 | |
460 | (define (statprof-stats-proc-name stats) (vector-ref stats 0)) | |
461 | (define (statprof-stats-%-time-in-proc stats) (vector-ref stats 1)) | |
462 | (define (statprof-stats-cum-secs-in-proc stats) (vector-ref stats 2)) | |
463 | (define (statprof-stats-self-secs-in-proc stats) (vector-ref stats 3)) | |
464 | (define (statprof-stats-calls stats) (vector-ref stats 4)) | |
465 | (define (statprof-stats-self-secs-per-call stats) (vector-ref stats 5)) | |
466 | (define (statprof-stats-cum-secs-per-call stats) (vector-ref stats 6)) | |
467 | ||
468 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
469 | ||
470 | (define (stats-sorter x y) | |
471 | (let ((diff (- (statprof-stats-self-secs-in-proc x) | |
472 | (statprof-stats-self-secs-in-proc y)))) | |
473 | (positive? | |
474 | (if (= diff 0) | |
475 | (- (statprof-stats-cum-secs-in-proc x) | |
476 | (statprof-stats-cum-secs-in-proc y)) | |
477 | diff)))) | |
478 | ||
479 | (define (statprof-display . port) | |
480 | "Displays a gprof-like summary of the statistics collected. Unless an | |
481 | optional @var{port} argument is passed, uses the current output port." | |
482 | (if (null? port) (set! port (current-output-port))) | |
483 | ||
484 | (cond | |
485 | ((zero? (statprof-sample-count)) | |
486 | (format port "No samples recorded.\n")) | |
487 | (else | |
488 | (let* ((stats-list (statprof-fold-call-data | |
489 | (lambda (data prior-value) | |
490 | (cons (statprof-call-data->stats data) | |
491 | prior-value)) | |
492 | '())) | |
493 | (sorted-stats (sort stats-list stats-sorter))) | |
494 | ||
495 | (define (display-stats-line stats) | |
496 | (if %count-calls? | |
e1138ba1 | 497 | (format port "~6,2f ~9,2f ~9,2f ~7d ~8,2f ~8,2f " |
47f3ce52 AW |
498 | (statprof-stats-%-time-in-proc stats) |
499 | (statprof-stats-cum-secs-in-proc stats) | |
500 | (statprof-stats-self-secs-in-proc stats) | |
501 | (statprof-stats-calls stats) | |
502 | (* 1000 (statprof-stats-self-secs-per-call stats)) | |
503 | (* 1000 (statprof-stats-cum-secs-per-call stats))) | |
504 | (format port "~6,2f ~9,2f ~9,2f " | |
505 | (statprof-stats-%-time-in-proc stats) | |
506 | (statprof-stats-cum-secs-in-proc stats) | |
507 | (statprof-stats-self-secs-in-proc stats))) | |
508 | (display (statprof-stats-proc-name stats) port) | |
509 | (newline port)) | |
510 | ||
511 | (if %count-calls? | |
512 | (begin | |
513 | (format port "~5a ~10a ~7a ~8a ~8a ~8a ~8@a\n" | |
514 | "% " "cumulative" "self" "" "self" "total" "") | |
515 | (format port "~5a ~9a ~8a ~8a ~8a ~8a ~8@a\n" | |
516 | "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "name")) | |
517 | (begin | |
518 | (format port "~5a ~10a ~7a ~8@a\n" | |
519 | "%" "cumulative" "self" "") | |
520 | (format port "~5a ~10a ~7a ~8@a\n" | |
521 | "time" "seconds" "seconds" "name"))) | |
522 | ||
523 | (for-each display-stats-line sorted-stats) | |
524 | ||
525 | (display "---\n" port) | |
526 | (simple-format #t "Sample count: ~A\n" (statprof-sample-count)) | |
527 | (simple-format #t "Total time: ~A seconds (~A seconds in GC)\n" | |
528 | (statprof-accumulated-time) | |
529 | (/ gc-time-taken internal-time-units-per-second)))))) | |
530 | ||
531 | (define (statprof-display-anomolies) | |
532 | "A sanity check that attempts to detect anomolies in statprof's | |
533 | statistics.@code{}" | |
534 | (statprof-fold-call-data | |
535 | (lambda (data prior-value) | |
536 | (if (and %count-calls? | |
537 | (zero? (call-data-call-count data)) | |
c165c50d | 538 | (positive? (call-data-cum-sample-count data))) |
47f3ce52 AW |
539 | (simple-format #t |
540 | "==[~A ~A ~A]\n" | |
541 | (call-data-name data) | |
542 | (call-data-call-count data) | |
c165c50d | 543 | (call-data-cum-sample-count data)))) |
47f3ce52 AW |
544 | #f) |
545 | (simple-format #t "Total time: ~A\n" (statprof-accumulated-time)) | |
546 | (simple-format #t "Sample count: ~A\n" (statprof-sample-count))) | |
547 | ||
548 | (define (statprof-accumulated-time) | |
549 | "Returns the time accumulated during the last statprof run.@code{}" | |
550 | (if (positive? profile-level) | |
551 | (error "Can't get accumulated time while profiler is running.")) | |
552 | (/ accumulated-time internal-time-units-per-second)) | |
553 | ||
554 | (define (statprof-sample-count) | |
555 | "Returns the number of samples taken during the last statprof run.@code{}" | |
556 | (if (positive? profile-level) | |
557 | (error "Can't get accumulated time while profiler is running.")) | |
558 | sample-count) | |
559 | ||
560 | (define statprof-call-data-name call-data-name) | |
561 | (define statprof-call-data-calls call-data-call-count) | |
562 | (define statprof-call-data-cum-samples call-data-cum-sample-count) | |
563 | (define statprof-call-data-self-samples call-data-self-sample-count) | |
564 | ||
565 | (define (statprof-fetch-stacks) | |
566 | "Returns a list of stacks, as they were captured since the last call | |
567 | to @code{statprof-reset}. | |
568 | ||
569 | Note that stacks are only collected if the @var{full-stacks?} argument | |
570 | to @code{statprof-reset} is true." | |
571 | stacks) | |
572 | ||
573 | (define procedure=? | |
574 | (if (false-if-exception (resolve-interface '(system base compile))) | |
575 | (lambda (a b) | |
576 | (cond | |
577 | ((eq? a b)) | |
e1138ba1 AW |
578 | ((and (program? a) (program? b)) |
579 | (eq? (program-objcode a) (program-objcode b))) | |
47f3ce52 AW |
580 | (else |
581 | #f))) | |
582 | (lambda (a b) | |
583 | (cond | |
584 | ((eq? a b)) | |
585 | ((and (closure? a) (closure? b) | |
586 | (procedure-source a) (procedure-source b)) | |
587 | (and (eq? (procedure-name a) (procedure-name b)) | |
588 | (equal? (procedure-source a) (procedure-source b)))) | |
589 | (else | |
590 | #f))))) | |
591 | ||
592 | ;; tree ::= (car n . tree*) | |
593 | ||
594 | (define (lists->trees lists equal?) | |
595 | (let lp ((in lists) (n-terminal 0) (tails '())) | |
596 | (cond | |
597 | ((null? in) | |
598 | (let ((trees (map (lambda (tail) | |
599 | (cons (car tail) | |
600 | (lists->trees (cdr tail) equal?))) | |
601 | tails))) | |
602 | (cons (apply + n-terminal (map cadr trees)) | |
603 | (sort trees | |
604 | (lambda (a b) (> (cadr a) (cadr b))))))) | |
605 | ((null? (car in)) | |
606 | (lp (cdr in) (1+ n-terminal) tails)) | |
607 | ((find (lambda (x) (equal? (car x) (caar in))) | |
608 | tails) | |
609 | => (lambda (tail) | |
610 | (lp (cdr in) | |
611 | n-terminal | |
612 | (assq-set! tails | |
613 | (car tail) | |
614 | (cons (cdar in) (cdr tail)))))) | |
615 | (else | |
616 | (lp (cdr in) | |
617 | n-terminal | |
618 | (acons (caar in) (list (cdar in)) tails)))))) | |
619 | ||
620 | (define (stack->procedures stack) | |
621 | (filter identity | |
622 | (unfold-right (lambda (x) (not x)) | |
623 | frame-procedure | |
624 | frame-previous | |
625 | (stack-ref stack 0)))) | |
626 | ||
627 | (define (statprof-fetch-call-tree) | |
628 | "Return a call tree for the previous statprof run. | |
629 | ||
630 | The return value is a list of nodes, each of which is of the type: | |
631 | @code | |
632 | node ::= (@var{proc} @var{count} . @var{nodes}) | |
633 | @end code" | |
634 | (cons #t (lists->trees (map stack->procedures stacks) procedure=?))) | |
635 | ||
e1138ba1 AW |
636 | (define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f) |
637 | (full-stacks? #f)) | |
638 | "Profiles the execution of @var{thunk}. | |
639 | ||
640 | The stack will be sampled @var{hz} times per second, and the thunk itself will | |
641 | be called @var{loop} times. | |
642 | ||
643 | If @var{count-calls?} is true, all procedure calls will be recorded. This | |
644 | operation is somewhat expensive. | |
645 | ||
646 | If @var{full-stacks?} is true, at each sample, statprof will store away the | |
647 | whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or | |
648 | @code{statprof-fetch-call-tree} to retrieve the last-stored stacks." | |
649 | ||
650 | (dynamic-wind | |
651 | (lambda () | |
652 | (statprof-reset (inexact->exact (floor (/ 1 hz))) | |
653 | (inexact->exact (* 1e6 (- (/ 1 hz) | |
654 | (floor (/ 1 hz))))) | |
655 | count-calls? | |
656 | full-stacks?) | |
657 | (statprof-start)) | |
658 | (lambda () | |
659 | (let lp ((i loop)) | |
660 | (if (not (zero? i)) | |
661 | (begin | |
662 | (thunk) | |
663 | (lp (1- i)))))) | |
664 | (lambda () | |
665 | (statprof-stop) | |
666 | (statprof-display) | |
667 | (set! procedure-data #f)))) | |
668 | ||
47f3ce52 AW |
669 | (define-macro (with-statprof . args) |
670 | "Profiles the expressions in its body. | |
671 | ||
672 | Keyword arguments: | |
673 | ||
674 | @table @code | |
675 | @item #:loop | |
676 | Execute the body @var{loop} number of times, or @code{#f} for no looping | |
677 | ||
678 | default: @code{#f} | |
679 | @item #:hz | |
680 | Sampling rate | |
681 | ||
682 | default: @code{20} | |
683 | @item #:count-calls? | |
684 | Whether to instrument each function call (expensive) | |
685 | ||
686 | default: @code{#f} | |
687 | @item #:full-stacks? | |
688 | Whether to collect away all sampled stacks into a list | |
689 | ||
690 | default: @code{#f} | |
691 | @end table" | |
692 | (define (kw-arg-ref kw args def) | |
693 | (cond | |
694 | ((null? args) (error "Invalid macro body")) | |
695 | ((keyword? (car args)) | |
696 | (if (eq? (car args) kw) | |
697 | (cadr args) | |
698 | (kw-arg-ref kw (cddr args) def))) | |
699 | ((eq? kw #f def) ;; asking for the body | |
700 | args) | |
701 | (else def))) ;; kw not found | |
e1138ba1 AW |
702 | `((@ (statprof) statprof) |
703 | (lambda () ,@(kw-arg-ref #f args #f)) | |
704 | #:loop ,(kw-arg-ref #:loop args 1) | |
705 | #:hz ,(kw-arg-ref #:hz args 100) | |
706 | #:count-calls? ,(kw-arg-ref #:count-calls? args #f) | |
707 | #:full-stacks? ,(kw-arg-ref #:full-stacks? args #f))) | |
708 |