/[cmucl]/src/code/profile.lisp
ViewVC logotype

Contents of /src/code/profile.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42 - (show annotations)
Fri Mar 19 15:18:59 2010 UTC (4 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.41: +3 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Package: Profile -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/profile.lisp,v 1.42 2010/03/19 15:18:59 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Description: Simple profiling facility.
13 ;;;
14 ;;; Author: Skef Wholey, Rob MacLachlan
15 ;;;
16 ;;; Compatibility: Runs in any valid Common Lisp. Three small implementation-
17 ;;; dependent changes can be made to improve performance and prettiness.
18 ;;;
19 ;;; Dependencies: The macro Quickly-Get-Time and the function
20 ;;; Required-Arguments should probably be tailored to the implementation for
21 ;;; the best results. They will default to working, albeit inefficent, forms
22 ;;; in non-CMU implementations. The Total-Consing macro is used to profile
23 ;;; consing: in unknown implementations 0 will be used.
24 ;;; See the "Implementation Parameters" section.
25 ;;;
26 ;;; Note: a timing overhead factor is computed when REPORT-TIME is first
27 ;;; called. This will be incorrect if profiling code is run in a different
28 ;;; environment than the first call to REPORT-TIME. For example, saving a core
29 ;;; image on a high performance machine and running it on a low performance one
30 ;;; will result in use of an erroneously small timing overhead factor. In CMU
31 ;;; CL, this cache is invalidated when a core is saved.
32 ;;;
33
34 (intl:textdomain "cmucl")
35
36 (defpackage "PROFILE"
37 (:use :common-lisp :ext :fwrappers)
38 (:export *timed-functions* profile profile-all unprofile reset-time
39 report-time report-time-custom *default-report-time-printfunction*
40 with-spacereport print-spacereports reset-spacereports
41 delete-spacereports *insert-spacereports*
42 *no-calls* *no-calls-limit*))
43
44 (in-package "PROFILE")
45
46
47 ;;;; Implementation dependent interfaces:
48
49 (defconstant quick-time-units-per-second internal-time-units-per-second)
50
51 (defmacro quickly-get-time ()
52 `(the time-type (get-internal-run-time)))
53
54 ;;;
55 ;;; The type of the result from quickly-get-time.
56 ;;;
57 (deftype time-type () '(unsigned-byte 29))
58
59 ;;;
60 ;;; Return two values: the first is the number of required arguments,
61 ;;; and the second is T iff NAME has any non-required arguments
62 ;;; (e.g. &OPTIONAL, &REST, &KEY).
63 ;;;
64 (defun required-arguments (name)
65 (let ((type (ext:info function type name)))
66 (cond ((not (kernel:function-type-p type))
67 (values 0 t))
68 (t
69 (values (length (kernel:function-type-required type))
70 (if (or (kernel:function-type-optional type)
71 (kernel:function-type-keyp type)
72 (kernel:function-type-rest type))
73 t nil))))))
74
75 ;;;
76 ;;; TOTAL-CONSING is called to find the total number of bytes consed
77 ;;; since the beginning of time.
78 ;;;
79 (declaim (inline total-consing))
80 (defun total-consing () (ext:get-bytes-consed-dfixnum))
81
82 ;;;
83 ;;; The type of the result of TOTAL-CONSING.
84 ;;;
85 (deftype consing-type () '(and fixnum unsigned-byte))
86
87 ;;;
88 ;;; On the CMUCL x86 port the return address is represented as a SAP
89 ;;; and to save the costly calculation of the SAPs code object the
90 ;;; profiler maintains callers as SAPs. These SAPs will become invalid
91 ;;; if a caller code object moves, so this should be prevented by the
92 ;;; use of purify or by moving code objects into an older generation
93 ;;; when using GENCGC.
94 ;;;
95 (defmacro get-caller-info ()
96 `(nth-value 1 (kernel:%caller-frame-and-pc)))
97
98 #-x86
99 (defun print-caller-info (info stream)
100 (prin1 (kernel:lra-code-header info) stream))
101
102 #+x86
103 (defun print-caller-info (info stream)
104 (prin1 (nth-value 1 (di::compute-lra-data-from-pc info)) stream))
105
106
107 ;;;; Global data structures:
108
109 (defvar *timed-functions* ()
110 "List of functions that are currently being timed.")
111
112 (defvar *no-calls* nil
113 "A list of profiled functions which weren't called.")
114
115 (defvar *no-calls-limit* 20
116 "If the number of profiled functions that were not called is less than
117 this, the functions are listed. If NIL, then always list the functions.")
118
119 ;;;
120 ;;; This is stored as user-data of profile fwrappers.
121 ;;;
122 (defstruct (profile-info
123 (:conc-name pi-)
124 (:constructor make-profile-info (function-name callers-p)))
125 ;;
126 ;; The name of the function being profiled.
127 function-name
128 ;;
129 ;; True if :CALLERS arg was given to PROFILE.
130 (callers-p nil :type boolean)
131 ;;
132 ;; Various counters for profiling.
133 (count 0 :type fixnum)
134 (time 0 :type time-type)
135 (consed-h 0 :type dfixnum:dfparttype)
136 (consed-l 0 :type dfixnum:dfparttype)
137 (consed-w/c-h 0 :type dfixnum:dfparttype)
138 (consed-w/c-l 0 :type dfixnum:dfparttype)
139 (profile 0 :type integer)
140 (callers () :type list))
141
142 ;;;
143 ;;; Reset counters of the given PROFILE-INFO
144 ;;;
145 (defun reset-profile-info (info)
146 (setf (pi-count info) 0
147 (pi-time info) 0
148 (pi-consed-h info) 0
149 (pi-consed-l info) 0
150 (pi-consed-w/c-h info) 0
151 (pi-consed-w/c-l info) 0
152 (pi-profile info) 0
153 (pi-callers info) ()))
154
155 ;;;
156 ;;; Return various profiling information from INFO as multiple values.
157 ;;;
158 (defun profile-info-profiling-values (info)
159 (values (pi-count info)
160 (pi-time info)
161 (dfixnum:dfixnum-pair-integer (pi-consed-h info)
162 (pi-consed-l info))
163 (dfixnum:dfixnum-pair-integer (pi-consed-w/c-h info)
164 (pi-consed-w/c-l info))
165 (pi-profile info)
166 (pi-callers info)))
167
168 ;;;
169 ;;; These variables are used to subtract out the time and consing for
170 ;;; recursive and other dynamically nested profiled calls. The total
171 ;;; resource consumed for each nested call is added into the
172 ;;; appropriate variable. When the outer function returns, these
173 ;;; amounts are subtracted from the total.
174 ;;;
175 ;;; *ENCLOSED-CONSING-H* and *ENCLOSED-CONSING-L* represent the total
176 ;;; consing as a pair of fixnum-sized integers to reduce consing and
177 ;;; allow for about 2^58 bytes of total consing. (Assumes positive
178 ;;; fixnums are 29 bits long).
179 ;;;
180 (defvar *enclosed-time* 0)
181 (defvar *enclosed-consing-h* 0)
182 (defvar *enclosed-consing-l* 0)
183 (defvar *enclosed-profilings* 0)
184 (declaim (type time-type *enclosed-time*))
185 (declaim (type dfixnum:dfparttype *enclosed-consing-h*))
186 (declaim (type dfixnum:dfparttype *enclosed-consing-l*))
187 (declaim (fixnum *enclosed-profilings*))
188
189
190 ;;;
191 ;;; The number of seconds a bare function call takes. Factored into
192 ;;; the other overheads, but not used for itself.
193 ;;;
194 (defvar *call-overhead*)
195
196 ;;;
197 ;;; The number of seconds that will be charged to a profiled function
198 ;;; due to the profiling code.
199 ;;;
200 (defvar *internal-profile-overhead*)
201
202 ;;;
203 ;;; The number of seconds of overhead for profiling that a single
204 ;;; profiled call adds to the total runtime for the program.
205 ;;;
206 (defvar *total-profile-overhead*)
207
208 (declaim (single-float *call-overhead* *internal-profile-overhead*
209 *total-profile-overhead*))
210
211
212 ;;;; Profile encapsulations:
213
214 (eval-when (:compile-toplevel :load-toplevel :execute)
215
216 ;;;
217 ;;; Names of fwrappers look like (PROFILE <nreq> <optionals-p>).
218 ;;; <Nreq> is the number of required parameters, <optionals-p> is
219 ;;; true if the fwrapper is for functions with optional arguments.
220 ;;;
221 (define-function-name-syntax profile (name)
222 (when (integerp (cadr name))
223 (values t 'profile)))
224
225 ;;;
226 ;;; Return the profile fwrapper name for profiling a function
227 ;;; with NREQ required arguments and optional arguments according
228 ;;; to OPTIONALS-P.
229 ;;;
230 (defun make-profile-fwrapper-name (nreq optionals-p)
231 `(profile ,nreq ,optionals-p))
232
233 ;;;
234 ;;; Return a DEFINE-FWRAPPER form for profiling a function with
235 ;;; arguments according to NREQ and OPTIONALS-P.
236 ;;;
237 (defun make-profile-fwrapper (nreq optionals-p)
238 (let ((req (loop repeat nreq collect (gensym)))
239 (name (make-profile-fwrapper-name nreq optionals-p)))
240 `(define-fwrapper ,name (,@req ,@(if optionals-p `(&rest .rest.)))
241 (let* ((info (fwrapper-user-data fwrapper))
242 (fn-name (pi-function-name info))
243 (fdefn (lisp::fdefinition-object fn-name nil)))
244 ;;
245 ;; "Deactivate" the profile fwrapper for the time it is
246 ;; running to ease profiling of functions used in the
247 ;; implementation of PROFILE itself.
248 (letf (((lisp::fdefn-function fdefn) (fwrapper-next fwrapper)))
249 (incf (pi-count info))
250 ;;
251 ;; If :CALLERS was specified for profiling, record caller
252 ;; information.
253 (when (pi-callers-p info)
254 (let ((caller (get-caller-info)))
255 (do ((prev nil current)
256 (current (pi-callers info) (cdr current)))
257 ((null current)
258 (push (cons caller 1) (pi-callers info)))
259 (let ((old-caller-info (car current)))
260 (when (progn #-x86 (eq caller (car old-caller-info))
261 #+x86 (sys:sap= caller (car old-caller-info)))
262 (if prev
263 (setf (cdr prev) (cdr current))
264 (setf (pi-callers info) (cdr current)))
265 (setf (cdr old-caller-info)
266 (the fixnum (+ (cdr old-caller-info) 1)))
267 (setf (cdr current) (pi-callers info))
268 (setf (pi-callers info) current)
269 (return))))))
270
271 (let ((time-inc 0)
272 (cons-inc-h 0)
273 (cons-inc-l 0)
274 (profile-inc 0))
275 (declare (type time-type time-inc)
276 (type dfixnum:dfparttype cons-inc-h cons-inc-l)
277 (fixnum profile-inc))
278 (multiple-value-prog1
279 (let ((start-time (quickly-get-time))
280 (start-consed-h 0)
281 (start-consed-l 0)
282 (end-consed-h 0)
283 (end-consed-l 0)
284 (*enclosed-time* 0)
285 (*enclosed-consing-h* 0)
286 (*enclosed-consing-l* 0)
287 (*enclosed-profilings* 0))
288 (dfixnum:dfixnum-set-pair start-consed-h
289 start-consed-l
290 (total-consing))
291 (multiple-value-prog1
292 (call-next-function)
293 (setq time-inc
294 #-BSD (- (quickly-get-time) start-time)
295 #+BSD (max (- (quickly-get-time) start-time) 0))
296 ;; How much did we cons so far?
297 (dfixnum:dfixnum-set-pair end-consed-h
298 end-consed-l
299 (total-consing))
300 (dfixnum:dfixnum-copy-pair cons-inc-h cons-inc-l
301 end-consed-h
302 end-consed-l)
303 (dfixnum:dfixnum-dec-pair cons-inc-h cons-inc-l
304 start-consed-h
305 start-consed-l)
306 ;; (incf consed (- cons-inc *enclosed-consing*))
307 (dfixnum:dfixnum-inc-pair (pi-consed-h info)
308 (pi-consed-l info)
309 cons-inc-h cons-inc-l)
310 (dfixnum:dfixnum-inc-pair (pi-consed-w/c-h info)
311 (pi-consed-w/c-l info)
312 cons-inc-h cons-inc-l)
313 (setq profile-inc *enclosed-profilings*)
314 (incf (pi-time info)
315 (the time-type
316 #-BSD
317 (- time-inc *enclosed-time*)
318 #+BSD
319 (max (- time-inc *enclosed-time*) 0)))
320 (dfixnum:dfixnum-dec-pair (pi-consed-h info)
321 (pi-consed-l info)
322 *enclosed-consing-h*
323 *enclosed-consing-l*)
324 (incf (pi-profile info) profile-inc)))
325 (incf *enclosed-time* time-inc)
326 ;; *enclosed-consing* = *enclosed-consing + cons-inc
327 (dfixnum:dfixnum-inc-pair *enclosed-consing-h*
328 *enclosed-consing-l*
329 cons-inc-h
330 cons-inc-l)))))))))
331
332 ;;;
333 ;;; Pre-define some profile fwrappers.
334 ;;;
335 (macrolet ((def-profile-fwrapper (nreq)
336 `(progn
337 ,(make-profile-fwrapper nreq t)
338 ,(make-profile-fwrapper nreq nil))))
339 (def-profile-fwrapper 0)
340 (def-profile-fwrapper 1)
341 (def-profile-fwrapper 2)
342 (def-profile-fwrapper 3))
343
344 #+(or)
345 (defun ensure-profile-fwrapper (nreq optionals-p)
346 "Ensure that a profile fwrapper for functions with NREQ required
347 arguments and optional arguments according to OPTIONALS-P exists.
348 Return the name of that fwrapper."
349 (let ((name (make-profile-fwrapper-name nreq optionals-p)))
350 (unless (fboundp name)
351 (without-package-locks
352 (eval (make-profile-fwrapper nreq optionals-p))
353 (compile name)))
354 name))
355
356 (defun ensure-profile-fwrapper (nreq optionals-p)
357 "Ensure that a profile fwrapper for functions with NREQ required
358 arguments and optional arguments according to OPTIONALS-P exists.
359 Return the name of that fwrapper."
360 (let ((name (make-profile-fwrapper-name nreq optionals-p)))
361 (unless (fboundp name)
362 (without-package-locks
363 ;; I (rtoy) do not know why the above version does not work,
364 ;; but this seems to work better.
365 (destructuring-bind (def name args &body body)
366 (macroexpand-1 (make-profile-fwrapper nreq optionals-p))
367 (declare (ignore def))
368 (compile name `(lambda ,args ,@body)))))
369 name))
370
371 (defun find-profile-fwrapper (name)
372 "Return the profile FWRAPPER object on function NAME, if any."
373 (find-fwrapper name :type 'profile))
374
375 (defun pi-or-lose (name)
376 "Return the PROFILE-INFO for function NAME.
377 Signal an error if NAME is not profiled."
378 (let ((f (find-profile-fwrapper name)))
379 (if f
380 (fwrapper-user-data f)
381 (error "No profile info for ~s" name))))
382
383
384 ;;; Interfaces:
385
386 ;;; PROFILE-1-FUNCTION -- Internal
387 ;;;
388 ;;; Profile the function Name. If already profiled, unprofile first.
389 ;;;
390 (defun profile-1-function (name callers-p)
391 (if (fboundp name)
392 (multiple-value-bind (nreq optionals-p)
393 (required-arguments name)
394 (when (find-profile-fwrapper name)
395 (warn "~s already profiled, unprofiling it first" name)
396 (unprofile-1-function name))
397 (let ((ctor (ensure-profile-fwrapper nreq optionals-p)))
398 (fwrap name (fdefinition ctor) :type 'profile
399 :user-data (make-profile-info name callers-p))
400 (push name *timed-functions*)))
401 (warn "Ignoring undefined function ~s" name)))
402
403
404 ;;; PROFILE -- Public
405 ;;;
406 (defmacro profile (&rest names)
407 "PROFILE Name*
408 Wraps profiling code around the named functions. As in TRACE, the names are
409 not evaluated. If a function is already profiled, then unprofile and
410 reprofile (useful to notice function redefinition.) If a name is undefined,
411 then we give a warning and ignore it.
412
413 CLOS methods can be profiled by specifying names of the form
414 (METHOD <name> <qualifier>* (<specializer>*)), like in TRACE.
415
416 :METHODS Function-Form is a way of specifying that all methods of a
417 generic functions should be profiled. The Function-Form is
418 evaluated immediately, and the methods of the resulting generic
419 function are profiled.
420
421 If :CALLERS T appears, subsequent names have counts of the most
422 common calling functions recorded.
423
424 See also UNPROFILE, REPORT-TIME and RESET-TIME."
425 (collect ((binds) (forms))
426 (let ((names names)
427 (callers nil))
428 (loop
429 (unless names (return))
430 (let ((name (pop names)))
431 (cond ((eq name :callers)
432 (setq callers (not (null (pop names)))))
433 ;;
434 ;; Method functions.
435 #+pcl
436 ((and (consp name) (eq 'method (car name)))
437 (let ((fast-name `(pcl::fast-method ,@(cdr name))))
438 (forms `(when (fboundp ',name)
439 (profile-1-function ',name ,callers)
440 (reinitialize-method-function ',name)))
441 (forms `(when (fboundp ',fast-name)
442 (profile-1-function ',fast-name ,callers)
443 (reinitialize-method-function ',fast-name)))))
444 ;;
445 ;; All method of a generic function.
446 #+pcl
447 ((eq :methods name)
448 (let ((tem (gensym)))
449 (binds `(,tem ,(pop names)))
450 (forms `(dolist (name
451 (debug::all-method-function-names ,tem))
452 (when (fboundp name)
453 (profile-1-function name ,callers)
454 (reinitialize-method-function name))))))
455 (t
456 (forms `(profile-1-function ',name ,callers))))))
457 (if (binds)
458 `(let ,(binds) ,@(forms) (values))
459 `(progn ,@(forms) (values))))))
460
461 ;;; PROFILE-ALL -- Public
462 ;;;
463 ;;; Add profiling to all symbols in the given package.
464 ;;;
465 (defun profile-all (&key (package *package*) (callers-p nil)
466 (methods nil))
467 "PROFILE-ALL
468
469 Wraps profiling code around all functions in PACKAGE, which defaults
470 to *PACKAGE*. If a function is already profiled, then unprofile and
471 reprofile (useful to notice function redefinition.) If a name is
472 undefined, then we give a warning and ignore it. If CALLERS-P is T
473 names have counts of the most common calling functions recorded.
474
475 When called with arguments :METHODS T, profile all methods of all
476 generic function having names in the given package. Generic functions
477 themselves, that is, their dispatch functions, are left alone.
478
479 See also UNPROFILE, REPORT-TIME and RESET-TIME. "
480 (let ((package (if (packagep package)
481 package
482 (find-package package))))
483 (do-symbols (symbol package (values))
484 (when (and (eq (symbol-package symbol) package)
485 (fboundp symbol)
486 (not (special-operator-p symbol))
487 (or (not methods)
488 (not (typep (fdefinition symbol) 'generic-function))))
489 (profile-1-function symbol callers-p)))
490 ;;
491 ;; Profile all method functions whose generic function name
492 ;; is in the package.
493 (when methods
494 (dolist (name (debug::all-method-functions-in-package package))
495 (when (fboundp name)
496 (profile-1-function name callers-p)
497 (reinitialize-method-function name))))))
498
499 ;;; UNPROFILE -- Public
500 ;;;
501 (defmacro unprofile (&rest names)
502 "Unwraps the profiling code around the named functions. Names defaults to
503 the list of all currently profiled functions."
504 (collect ((binds) (forms))
505 (let ((names (or names *timed-functions*)))
506 (loop
507 (unless names (return))
508 (let ((name (pop names)))
509 (cond #+pcl
510 ((and (consp name)
511 (member (car name) '(method pcl::fast-method)))
512 (let ((name `(method ,@(cdr name)))
513 (fast-name `(pcl::fast-method ,@(cdr name))))
514 (forms `(when (fboundp ',name)
515 (unprofile-1-function ',name)
516 (reinitialize-method-function ',name)))
517 (forms `(when (fboundp ',fast-name)
518 (unprofile-1-function ',fast-name)
519 (reinitialize-method-function ',fast-name)))))
520 #+pcl
521 ((eq :methods name)
522 (let ((tem (gensym)))
523 (binds `(,tem ,(pop names)))
524 (forms `(dolist (name (debug::all-method-function-names ,tem))
525 (when (fboundp name)
526 (unprofile-1-function name)
527 (reinitialize-method-function name))))))
528 (t
529 (forms `(unprofile-1-function ',name))))))
530 (if (binds)
531 `(let ,(binds) ,@(forms) (values))
532 `(progn ,@(forms) (values))))))
533
534
535 ;;; UNPROFILE-1-FUNCTION -- Internal
536 ;;;
537 (defun unprofile-1-function (name)
538 (funwrap name :type 'profile)
539 (setq *timed-functions* (delete name *timed-functions* :test #'equal)))
540
541
542 (defun re-profile-redefined-function (name new-value)
543 (declare (ignore new-value))
544 (let (f)
545 (when (and (fboundp name)
546 (setq f (find-profile-fwrapper name)))
547 (profile-1-function name (pi-callers-p (fwrapper-user-data f))))))
548
549 (push #'re-profile-redefined-function ext:*setf-fdefinition-hook*)
550
551
552
553 ;;; COMPENSATE-TIME -- Internal
554 ;;;
555 ;;; Return our best guess for the run time in a function, subtracting out
556 ;;; factors for profiling overhead. We subtract out the internal overhead for
557 ;;; each call to this function, since the internal overhead is the part of the
558 ;;; profiling overhead for a function that is charged to that function.
559 ;;;
560 ;;; We also subtract out a factor for each call to a profiled function
561 ;;; within this profiled function. This factor is the total profiling overhead
562 ;;; *minus the internal overhead*. We don't subtract out the internal
563 ;;; overhead, since it was already subtracted when the nested profiled
564 ;;; functions subtracted their running time from the time for the enclosing
565 ;;; function.
566 ;;;
567 (defun compensate-time (calls time profile)
568 (let ((compensated
569 (- (/ (float time) (float quick-time-units-per-second))
570 (* *internal-profile-overhead* (float calls))
571 (* (- *total-profile-overhead* *internal-profile-overhead*)
572 (float profile)))))
573 (if (minusp compensated) 0.0 compensated)))
574
575
576 (defstruct width-info
577 cons
578 calls
579 time
580 time/call
581 cons/call)
582
583 ;; Compute and return the width of the field needed to hold the total
584 ;; time, total cons, total-calls, and the max time/call.
585 (defun compute-widths (info)
586 (let ((total-time 0)
587 (total-cons 0)
588 (total-calls 0)
589 (max-time/call 0)
590 (max-cons/call 0))
591 ;; Find the total time, total consing, total calls, and the max
592 ;; time/call
593 (dolist (item info)
594 (let ((time (time-info-time item)))
595 (incf total-time time)
596 (incf total-cons (time-info-consing item))
597 (incf total-calls (time-info-calls item))
598 (setf max-time/call (max max-time/call
599 (/ time (float (time-info-calls item)))))
600 (setf max-cons/call (max max-cons/call
601 (/ (time-info-consing item)
602 (float (time-info-calls item)))))))
603
604 ;; Figure out the width needed for total-time, total-cons,
605 ;; total-calls and the max-time/call. The total-cons is more
606 ;; complicated because we print the consing with comma
607 ;; separators. For total-time, we assume a default of "~10,3F";
608 ;; for total-calls, "~7D"; for time/call, "~10,5F". This is where
609 ;; the constants come from.
610 (flet ((safe-log10 (x)
611 ;; log base 10 of x, but any non-positive value of x, 0
612 ;; is ok for what we want.
613 (if (zerop x)
614 0.0
615 (log x 10))))
616 (let ((cons-length (ceiling (safe-log10 total-cons)))
617 (calls-length (ceiling (safe-log10 total-calls)))
618 (cons/call-len (ceiling (safe-log10 max-cons/call))))
619 ;; Adjust these to include the number of commas that will be
620 ;; printed.
621 (incf cons-length (floor (safe-log10 total-cons) 3))
622 (incf calls-length (floor (safe-log10 total-calls) 3))
623 (incf cons/call-len (floor (safe-log10 max-cons/call) 3))
624 (make-width-info :cons (max 9 cons-length)
625 :calls (max 7 calls-length)
626 :time (+ 4 (ceiling (safe-log10 total-time)))
627 :time/call (+ 6 (max 2 (ceiling (safe-log10 max-time/call))))
628 :cons/call (max 8 cons/call-len))))))
629
630 (defstruct (time-info
631 (:constructor make-time-info
632 (name calls time consing consing-w/c callers)))
633 name
634 calls
635 time
636 consing
637 consing-w/c
638 callers)
639
640 (defstruct (time-totals)
641 (time 0.0)
642 (consed 0)
643 (calls 0))
644
645 (defun report-times-time (time action &optional field-widths)
646 (multiple-value-bind (time-width cons-width calls-width time/call-width cons/call-width)
647 (if field-widths
648 (values (width-info-time field-widths)
649 (width-info-cons field-widths)
650 (width-info-calls field-widths)
651 (width-info-time/call field-widths)
652 (width-info-cons/call field-widths))
653 (values 9 9 7 10 10))
654 (case action
655 (:head
656 (format *trace-output*
657 "~&~V@A | ~V@A | ~V@A | ~V@A | ~V@A | Name:~@
658 -----------------------------------------------------------------------~%"
659 cons-width "Consed"
660 calls-width "Calls"
661 time-width "Secs"
662 time/call-width "Sec/Call"
663 cons/call-width "Bytes/C."
664 )
665 (return-from report-times-time))
666
667 (:tail
668 (format *trace-output*
669 "-------------------------------------------------------------------~@
670 ~V:D | ~V:D | ~V,3F | ~V:A | ~V:A | Total~%"
671 cons-width (time-totals-consed time)
672 calls-width (time-totals-calls time)
673 time-width (time-totals-time time)
674 time/call-width ""
675 cons/call-width ""))
676 (:sort (sort time #'>= :key #'time-info-time))
677 (:one-function
678 (format *trace-output*
679 "~V:D | ~V:D | ~V,3F | ~V,5F | ~V:D | ~S~%"
680 cons-width (floor (time-info-consing time))
681 calls-width (time-info-calls time)
682 time-width (time-info-time time)
683 time/call-width (/ (time-info-time time) (float (time-info-calls time)))
684 cons/call-width
685 (round
686 (/ (time-info-consing time) (float (time-info-calls time))))
687 (time-info-name time)))
688 (t
689 (error "Unknown action for profiler report: ~s" action)))))
690
691 (defun report-times-space (time action &optional field-widths)
692 (case action
693 (:head
694 (format *trace-output*
695 "~& Consed w/c | Consed | Calls | Sec/Call | Bytes/C. | Name:~@
696 -----------------------------------------------------------------------~%")
697 (return-from report-times-space))
698
699 (:tail
700 (format *trace-output*
701 "-------------------------------------------------------------------~@
702 :-) |~11:D |~10:D | | | Total~%"
703 (time-totals-consed time) (time-totals-calls time)))
704 (:sort (sort time #'>= :key #'time-info-consing))
705 (:one-function
706 (format *trace-output*
707 "~11:D |~11:D |~10:D |~10,5F |~10:D | ~S~%"
708 (floor (time-info-consing-w/c time))
709 (floor (time-info-consing time))
710 (time-info-calls time)
711 (/ (time-info-time time) (float (time-info-calls time)))
712 (round
713 (/ (time-info-consing time) (float (time-info-calls time))))
714 (time-info-name time)))
715 (t
716 (error "Unknown action for profiler report"))))
717
718 (defparameter *default-report-time-printfunction* #'report-times-time)
719
720 (defun %report-times (names
721 &key (printfunction *default-report-time-printfunction*))
722 (declare (optimize (speed 0)))
723 (unless (boundp '*call-overhead*)
724 (compute-time-overhead))
725 (let ((info ())
726 (no-call ())
727 (widths ()))
728 (dolist (name names)
729 (let ((pinfo (pi-or-lose name)))
730 (multiple-value-bind (calls time consing consing-w/c profile callers)
731 (profile-info-profiling-values pinfo)
732 (if (zerop calls)
733 (push name no-call)
734 (push (make-time-info name calls
735 (compensate-time calls time profile)
736 consing
737 consing-w/c
738 (sort (copy-seq callers)
739 #'>= :key #'cdr))
740 info)))))
741
742 (setq info (funcall printfunction info :sort))
743
744 (setf widths (compute-widths info))
745
746 (funcall printfunction nil :head widths)
747
748 (let ((totals (make-time-totals)))
749 (dolist (time info)
750 (incf (time-totals-time totals) (time-info-time time))
751 (incf (time-totals-calls totals) (time-info-calls time))
752 (incf (time-totals-consed totals) (time-info-consing time))
753
754 (funcall printfunction time :one-function widths)
755
756 (let ((callers (time-info-callers time))
757 (*print-readably* nil))
758 (when callers
759 (dolist (x (subseq callers 0 (min (length callers) 5)))
760 (format *trace-output* "~13T~10:D: " (cdr x))
761 (print-caller-info (car x) *trace-output*)
762 (terpri *trace-output*))
763 (terpri *trace-output*))))
764 (funcall printfunction totals :tail widths))
765
766 (when no-call
767 (setf *no-calls* no-call)
768 (if (and (realp *no-calls-limit*)
769 (>= (length no-call) *no-calls-limit*))
770 (format *trace-output*
771 "~%~D functions were not called. ~
772 See profile::*no-calls* for a list~%"
773 (length no-call))
774 (format *trace-output*
775 "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
776 (sort no-call #'string<
777 :key (lambda (n)
778 (if (symbolp n)
779 (symbol-name n)
780 (multiple-value-bind (valid block-name)
781 (ext:valid-function-name-p n)
782 (declare (ignore valid))
783 (if block-name
784 block-name
785 (princ-to-string n)))))))))
786 (values)))
787
788
789 (defmacro reset-time (&rest names)
790 "Resets the time counter for the named functions. Names defaults to the list
791 of all currently profiled functions."
792 `(%reset-time ,(if names `',names '*timed-functions*)))
793
794 (defun %reset-time (names)
795 (dolist (name names)
796 (reset-profile-info (pi-or-lose name)))
797 (values))
798
799
800 (defmacro report-time (&rest names)
801 "Reports the time spent in the named functions. Names defaults to the list
802 of all currently profiled functions."
803 `(%report-times ,(if names `',names '*timed-functions*)))
804
805 (defun report-time-custom (&key names printfunction)
806 "Reports the time spent in the named functions. Names defaults to the list
807 of all currently profiled functions. Uses printfunction."
808 (%report-times (or names *timed-functions*)
809 :printfunction
810 (or (typecase printfunction
811 (null *default-report-time-printfunction*)
812 (function printfunction)
813 (symbol
814 (case printfunction
815 (:space #'report-times-space)
816 (:time #'report-times-time))))
817 (error "Cannot handle printfunction ~s" printfunction))))
818
819
820 ;;;; Overhead computation.
821
822 ;;; We average the timing overhead over this many iterations.
823 ;;;
824 (defconstant timer-overhead-iterations 5000)
825
826
827 ;;; COMPUTE-TIME-OVERHEAD-AUX -- Internal
828 ;;;
829 ;;; Dummy function we profile to find profiling overhead. Declare
830 ;;; debug-info to make sure we have arglist info.
831 ;;;
832 (declaim (notinline compute-time-overhead-aux))
833 (defun compute-time-overhead-aux (x)
834 (declare (ext:optimize-interface (debug 2)))
835 (declare (ignore x)))
836
837
838 ;;; COMPUTE-TIME-OVERHEAD -- Internal
839 ;;;
840 ;;; Initialize the profiling overhead variables.
841 ;;;
842 (defun compute-time-overhead ()
843 (macrolet ((frob (var)
844 `(let ((start (quickly-get-time))
845 (fun (symbol-function 'compute-time-overhead-aux)))
846 (dotimes (i timer-overhead-iterations)
847 (funcall fun fun))
848 (setq ,var
849 (/ (float (- (quickly-get-time) start))
850 (float quick-time-units-per-second)
851 (float timer-overhead-iterations))))))
852 (frob *call-overhead*)
853
854 (unwind-protect
855 (progn
856 (profile compute-time-overhead-aux)
857 (frob *total-profile-overhead*)
858 (decf *total-profile-overhead* *call-overhead*)
859 (let ((pinfo (pi-or-lose 'compute-time-overhead-aux)))
860 (multiple-value-bind (calls time)
861 (profile-info-profiling-values pinfo)
862 (declare (ignore calls))
863 (setq *internal-profile-overhead*
864 (/ (float time)
865 (float quick-time-units-per-second)
866 (float timer-overhead-iterations))))))
867 (unprofile compute-time-overhead-aux))))
868
869 (pushnew (lambda ()
870 (makunbound '*call-overhead*))
871 ext:*before-save-initializations*)
872
873
874 ;;;
875 ;;; (with-spacereport <tag> <body> ...) and friends
876 ;;;
877
878 ;;; TODO:
879 ;;; - if counting place haven't been allocated at compile time, try to do it
880 ;;; at load time
881 ;;; - Introduce a mechanism that detects whether *all* calls were the same
882 ;;; amount of bytes (single variable).
883 ;;; - record the source file and place this report appears in
884 ;;; - detect whether this is a nested spacereport and if so, record
885 ;;; the outer reports
886
887 ;; This struct is used for whatever counting the checkpoints do
888 ;; AND
889 ;; stores information we find at compile time
890 (defstruct spacereport-info
891 (n 0 :type fixnum)
892 (consed-h 0 :type dfixnum:dfparttype)
893 (consed-l 0 :type dfixnum:dfparttype)
894 (codesize -1 :type fixnum))
895
896 ;; In the usual case, the hashtable with entries will be allocated at
897 ;; compile or load time
898 (eval-when (load eval)
899 (defvar *spacereports* (make-hash-table)))
900
901 ;;
902 ;; Helper functions
903 ;;
904 (defun format-quotient (p1 p2 width komma)
905 (let (format)
906 (cond ((= 0 p2)
907 (make-string width :initial-element #\ ))
908 ((and (integerp p1)
909 (integerp p2)
910 (zerop (rem p1 p2)))
911 (setf format (format nil "~~~d:D!~a"
912 (- width komma 1)
913 (make-string komma :initial-element #\ )))
914 (format nil format (/ p1 p2)))
915 (t
916 (setf format (format nil "~~~d,~df" width komma))
917 (format nil format (/ (float p1) (float p2)))))))
918
919 (defun deep-list-length (list)
920 (let ((length 0))
921 (dolist (e list)
922 (when (listp e)
923 (incf length (deep-list-length e)))
924 (incf length))
925 length))
926
927 ;; bunch for tests for above
928 #+nil
929 (defun test-format-quotient ()
930 (print (format-quotient 10 5 10 2))
931 (print (format-quotient 10 3 10 2))
932 (print (format-quotient 10 5 10 0))
933 (print (format-quotient 10 3 10 0))
934 (print (format-quotient 10 0 10 0)))
935
936 (defvar *insert-spacereports* t)
937
938 ;; Main wrapper macro for user - exported
939 (defmacro with-spacereport (name-or-args &body body)
940 (if (not *insert-spacereports*)
941 `(progn ,@body)
942 (let ((name
943 (typecase name-or-args
944 (symbol name-or-args)
945 (cons (first name-or-args))
946 (t (error "Spacereport args neither symbol nor cons") nil)))
947 (options (if (consp name-or-args)
948 (rest name-or-args)
949 nil)))
950 (when (gethash name *spacereports*)
951 (unless (find :mok options)
952 (warn "spacereport for ~a was requested before, resetting it"
953 name)))
954 (setf (gethash name *spacereports*) (make-spacereport-info))
955 (setf (spacereport-info-codesize (gethash name *spacereports*))
956 (deep-list-length body))
957
958 `(let* ((counterplace nil)
959 (place (gethash ,name *spacereports*))
960 (start-h 0)
961 (start-l 0))
962 (declare (type dfixnum:dfparttype start-h start-l))
963 (declare (type (or dfixnum:dfixnum null) counterplace))
964 (declare (type (or spacereport-info null) place))
965
966 ;; Make sure counter is there
967 (unless place
968 ;; Ups, it isn't, so create it...
969 (setf place (make-spacereport-info))
970 (setf (gethash ,name *spacereports*) place)
971 (print
972 "with-spaceprofile had to create place, leaked bytes to outer
973 spacereports in nested calls"))
974
975 ;; Remember bytes already consed at start
976 (setf counterplace (total-consing))
977 (dfixnum:dfixnum-set-pair start-h start-l counterplace)
978
979 (prog1
980 (progn ,@body)
981
982 (incf (spacereport-info-n place))
983 ;; Add bytes newly consed.
984 ;; first update counterplace.
985 (total-consing)
986 (dfixnum:dfixnum-inc-pair (spacereport-info-consed-h place)
987 (spacereport-info-consed-l place)
988 (dfixnum::dfixnum-h counterplace)
989 (dfixnum::dfixnum-l counterplace))
990 (dfixnum:dfixnum-dec-pair (spacereport-info-consed-h place)
991 (spacereport-info-consed-l place)
992 start-h
993 start-l))))))
994
995 (defun print-spacereports (&optional (stream *trace-output*))
996 (maphash (lambda (key value)
997 (format
998 stream
999 "~&~10:D bytes ~9:D calls ~a b/call: ~a (sz ~d)~%"
1000 (dfixnum:dfixnum-pair-integer
1001 (spacereport-info-consed-h value)
1002 (spacereport-info-consed-l value))
1003 (spacereport-info-n value)
1004 (format-quotient (dfixnum:dfixnum-pair-integer
1005 (spacereport-info-consed-h value)
1006 (spacereport-info-consed-l value))
1007 (spacereport-info-n value)
1008 10 2)
1009 key
1010 (spacereport-info-codesize value)))
1011 *spacereports*))
1012
1013 (defun reset-spacereports ()
1014 (maphash (lambda (key value)
1015 (declare (ignore key))
1016 (setf (spacereport-info-consed-h value) 0)
1017 (setf (spacereport-info-consed-l value) 0)
1018 (setf (spacereport-info-n value) 0))
1019 *spacereports*))
1020
1021 (defun delete-spacereports ()
1022 (maphash (lambda (key value)
1023 (declare (ignore value))
1024 (remhash key *spacereports*))
1025 *spacereports*))

  ViewVC Help
Powered by ViewVC 1.1.5