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