/[slime]/slime/metering.lisp
ViewVC logotype

Contents of /slime/metering.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Fri Apr 1 20:16:35 2005 UTC (9 years ago) by lgorrie
Branch: MAIN
CVS Tags: SLIME-2-1, SLIME-2-0, SLIME-1-2, SLIME-1-3, SLIME-1-2-1
Branch point for: contrib, fsm
Changes since 1.3: +21 -20 lines
Maybe fixed some openmcl breakage.
1 ;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*-
2 ;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>
3
4 ;;; ****************************************************************
5 ;;; Metering System ************************************************
6 ;;; ****************************************************************
7 ;;;
8 ;;; The Metering System is a portable Common Lisp code profiling tool.
9 ;;; It gathers timing and consing statistics for specified functions
10 ;;; while a program is running.
11 ;;;
12 ;;; The Metering System is a combination of
13 ;;; o the Monitor package written by Chris McConnell
14 ;;; o the Profile package written by Skef Wholey and Rob MacLachlan
15 ;;; The two systems were merged and extended by Mark Kantrowitz.
16 ;;;
17 ;;; Address: Carnegie Mellon University
18 ;;; School of Computer Science
19 ;;; Pittsburgh, PA 15213
20 ;;;
21 ;;; This code is in the public domain and is distributed without warranty
22 ;;; of any kind.
23 ;;;
24 ;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/
25 ;;;
26 ;;;
27
28 ;;; ********************************
29 ;;; Change Log *********************
30 ;;; ********************************
31 ;;;
32 ;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages.
33 ;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics
34 ;;; with respect to nested calls. (Allows it to subtract
35 ;;; total monitoring overhead for each function, not just
36 ;;; the time spent monitoring the function itself.)
37 ;;; 26-JUN-90 mk The table is now saved so that one may manipulate
38 ;;; the data (sorting it, etc.) even after the original
39 ;;; source of the data has been cleared.
40 ;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2
41 ;;; required-arguments functions for Lucid 3.0,
42 ;;; Franz Allegro CL, and MACL 1.3.2.
43 ;;; 25-JAN-91 mk Now uses fdefinition if available.
44 ;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl.
45 ;;; Much better solution for the fact that both call
46 ;;; themselves :allegro.
47 ;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded
48 ;;; uncompiled.
49 ;;; 5-JUL-91 mk When many unmonitored functions, print out number
50 ;;; instead of whole list.
51 ;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring
52 ;;; doesn't work in MCL, but fixed so that timing
53 ;;; statistics do.
54 ;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with
55 ;;; (and :ccl (not :lispworks)).
56 ;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0.
57 ;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1,
58 ;;; Lucid 4.0, ibcl
59 ;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible.
60 ;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL.
61 ;;; Purely to cut down on stale code (e.g. #+cltl2) in this
62 ;;; version that is bundled with SLIME.
63 ;;;
64 ;;;
65
66 ;;; ********************************
67 ;;; To Do **************************
68 ;;; ********************************
69 ;;;
70 ;;; - Need get-cons for Allegro, AKCL.
71 ;;; - Speed up monitoring code. Replace use of hash tables with an embedded
72 ;;; offset in an array so that it will be faster than using gethash.
73 ;;; (i.e., svref/closure reference is usually faster than gethash).
74 ;;; - Beware of (get-internal-run-time) overflowing. Yikes!
75 ;;; - Check robustness with respect to profiled functions.
76 ;;; - Check logic of computing inclusive and exclusive time and consing.
77 ;;; Especially wrt incf/setf comment below. Should be incf, so we
78 ;;; sum recursive calls.
79 ;;; - Add option to record caller statistics -- this would list who
80 ;;; called which functions and how often.
81 ;;; - switches to turn timing/CONSING statistics collection on/off.
82
83
84 ;;; ********************************
85 ;;; Notes **************************
86 ;;; ********************************
87 ;;;
88 ;;; METERING has been tested (successfully) in the following lisps:
89 ;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler
90 ;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
91 ;;; Macintosh Allegro Common Lisp (1.3.2)
92 ;;; Macintosh Common Lisp (2.0)
93 ;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1
94 ;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0
95 ;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1
96 ;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1
97 ;;; Lucid CL (Version 2.1 6-DEC-87)
98 ;;; Lucid Common Lisp (3.0)
99 ;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91)
100 ;;; AKCL (1.86, June 30, 1987 or later)
101 ;;; Ibuki Common Lisp (Version 2, release 01.027)
102 ;;; CLISP (January 1994)
103 ;;;
104 ;;; METERING needs to be tested in the following lisps:
105 ;;; Symbolics Common Lisp (8.0)
106 ;;; KCL (June 3, 1987 or later)
107 ;;; TI (Release 4.1 or later)
108 ;;; Golden Common Lisp (3.1 IBM-PC)
109 ;;; VAXLisp (2.0, 3.1)
110 ;;; Procyon Common Lisp
111
112
113 ;;; ****************************************************************
114 ;;; Documentation **************************************************
115 ;;; ****************************************************************
116 ;;;
117 ;;; This system runs in any valid Common Lisp. Four small
118 ;;; implementation-dependent changes can be made to improve performance
119 ;;; and prettiness. In the section labelled "Implementation Dependent
120 ;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS,
121 ;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation
122 ;;; for the best results. If GET-CONS is not specified for your
123 ;;; implementation, no consing information will be reported. The other
124 ;;; functions will default to working forms, albeit inefficient, in
125 ;;; non-CMU implementations. If you tailor these functions for a particular
126 ;;; version of Common Lisp, we'd appreciate receiving the code.
127 ;;;
128
129 ;;; ****************************************************************
130 ;;; Usage Notes ****************************************************
131 ;;; ****************************************************************
132 ;;;
133 ;;; SUGGESTED USAGE:
134 ;;;
135 ;;; Start by monitoring big pieces of the program, then carefully choose
136 ;;; which functions close to, but not in, the inner loop are to be
137 ;;; monitored next. Don't monitor functions that are called by other
138 ;;; monitored functions: you will only confuse yourself.
139 ;;;
140 ;;; If the per-call time reported is less than 1/10th of a second, then
141 ;;; consider the clock resolution and profiling overhead before you believe
142 ;;; the time. It may be that you will need to run your program many times
143 ;;; in order to average out to a higher resolution.
144 ;;;
145 ;;; The easiest way to use this package is to load it and execute either
146 ;;; (mon:with-monitoring (names*) ()
147 ;;; your-forms*)
148 ;;; or
149 ;;; (mon:monitor-form your-form)
150 ;;; The former allows you to specify which functions will be monitored; the
151 ;;; latter monitors all functions in the current package. Both automatically
152 ;;; produce a table of statistics. Other variants can be constructed from
153 ;;; the monitoring primitives, which are described below, along with a
154 ;;; fuller description of these two macros.
155 ;;;
156 ;;; For best results, compile this file before using.
157 ;;;
158 ;;;
159 ;;; CLOCK RESOLUTION:
160 ;;;
161 ;;; Unless you are very lucky, the length of your machine's clock "tick" is
162 ;;; probably much longer than the time it takes a simple function to run.
163 ;;; For example, on the IBM RT, the clock resolution is 1/50th of a second.
164 ;;; This means that if a function is only called a few times, then only the
165 ;;; first couple of decimal places are really meaningful.
166 ;;;
167 ;;;
168 ;;; MONITORING OVERHEAD:
169 ;;;
170 ;;; The added monitoring code takes time to run every time that the monitored
171 ;;; function is called, which can disrupt the attempt to collect timing
172 ;;; information. In order to avoid serious inflation of the times for functions
173 ;;; that take little time to run, an estimate of the overhead due to monitoring
174 ;;; is subtracted from the times reported for each function.
175 ;;;
176 ;;; Although this correction works fairly well, it is not totally accurate,
177 ;;; resulting in times that become increasingly meaningless for functions
178 ;;; with short runtimes. For example, subtracting the estimated overhead
179 ;;; may result in negative times for some functions. This is only a concern
180 ;;; when the estimated profiling overhead is many times larger than
181 ;;; reported total CPU time.
182 ;;;
183 ;;; If you monitor functions that are called by monitored functions, in
184 ;;; :inclusive mode the monitoring overhead for the inner function is
185 ;;; subtracted from the CPU time for the outer function. [We do this by
186 ;;; counting for each function not only the number of calls to *this*
187 ;;; function, but also the number of monitored calls while it was running.]
188 ;;; In :exclusive mode this is not necessary, since we subtract the
189 ;;; monitoring time of inner functions, overhead & all.
190 ;;;
191 ;;; Otherwise, the estimated monitoring overhead is not represented in the
192 ;;; reported total CPU time. The sum of total CPU time and the estimated
193 ;;; monitoring overhead should be close to the total CPU time for the
194 ;;; entire monitoring run (as determined by TIME).
195 ;;;
196 ;;; A timing overhead factor is computed at load time. This will be incorrect
197 ;;; if the monitoring code is run in a different environment than this file
198 ;;; was loaded in. For example, saving a core image on a high performance
199 ;;; machine and running it on a low performance one will result in the use
200 ;;; of an erroneously small overhead factor.
201 ;;;
202 ;;;
203 ;;; If your times vary widely, possible causes are:
204 ;;; - Garbage collection. Try turning it off, then running your code.
205 ;;; Be warned that monitoring code will probably cons when it does
206 ;;; (get-internal-run-time).
207 ;;; - Swapping. If you have enough memory, execute your form once
208 ;;; before monitoring so that it will be swapped into memory. Otherwise,
209 ;;; get a bigger machine!
210 ;;; - Resolution of internal-time-units-per-second. If this value is
211 ;;; too low, then the timings become wild. You can try executing more
212 ;;; of whatever your test is, but that will only work if some of your
213 ;;; paths do not match the timer resolution.
214 ;;; internal-time-units-per-second is so coarse -- on a Symbolics it is
215 ;;; 977, in MACL it is 60.
216 ;;;
217 ;;;
218
219 ;;; ****************************************************************
220 ;;; Interface ******************************************************
221 ;;; ****************************************************************
222 ;;;
223 ;;; WITH-MONITORING (&rest functions) [Macro]
224 ;;; (&optional (nested :exclusive)
225 ;;; (threshold 0.01)
226 ;;; (key :percent-time))
227 ;;; &body body
228 ;;; The named functions will be set up for monitoring, the body forms executed,
229 ;;; a table of results printed, and the functions unmonitored. The nested,
230 ;;; threshold, and key arguments are passed to report-monitoring below.
231 ;;;
232 ;;; MONITOR-FORM form [Macro]
233 ;;; &optional (nested :exclusive)
234 ;;; (threshold 0.01)
235 ;;; (key :percent-time)
236 ;;; All functions in the current package are set up for monitoring while
237 ;;; the form is executed, and automatically unmonitored after a table of
238 ;;; results has been printed. The nested, threshold, and key arguments
239 ;;; are passed to report-monitoring below.
240 ;;;
241 ;;; *MONITORED-FUNCTIONS* [Variable]
242 ;;; This holds a list of all functions that are currently being monitored.
243 ;;;
244 ;;; MONITOR &rest names [Macro]
245 ;;; The named functions will be set up for monitoring by augmenting
246 ;;; their function definitions with code that gathers statistical information
247 ;;; about code performance. As with the TRACE macro, the function names are
248 ;;; not evaluated. Calls the function MON::MONITORING-ENCAPSULATE on each
249 ;;; function name. If no names are specified, returns a list of all
250 ;;; monitored functions.
251 ;;;
252 ;;; If name is not a symbol, it is evaled to return the appropriate
253 ;;; closure. This allows you to monitor closures stored anywhere like
254 ;;; in a variable, array or structure. Most other monitoring packages
255 ;;; can't handle this.
256 ;;;
257 ;;; MONITOR-ALL &optional (package *package*) [Function]
258 ;;; Monitors all functions in the specified package, which defaults to
259 ;;; the current package.
260 ;;;
261 ;;; UNMONITOR &rest names [Macro]
262 ;;; Removes monitoring code from the named functions. If no names are
263 ;;; specified, all currently monitored functions are unmonitored.
264 ;;;
265 ;;; RESET-MONITORING-INFO name [Function]
266 ;;; Resets the monitoring statistics for the specified function.
267 ;;;
268 ;;; RESET-ALL-MONITORING [Function]
269 ;;; Resets the monitoring statistics for all monitored functions.
270 ;;;
271 ;;; MONITORED name [Function]
272 ;;; Predicate to test whether a function is monitored.
273 ;;;
274 ;;; REPORT-MONITORING &optional names [Function]
275 ;;; (nested :exclusive)
276 ;;; (threshold 0.01)
277 ;;; (key :percent-time)
278 ;;; Creates a table of monitoring information for the specified list
279 ;;; of names, and displays the table using display-monitoring-results.
280 ;;; If names is :all or nil, uses all currently monitored functions.
281 ;;; Takes the following arguments:
282 ;;; - NESTED specifies whether nested calls of monitored functions
283 ;;; are included in the times for monitored functions.
284 ;;; o If :inclusive, the per-function information is for the entire
285 ;;; duration of the monitored function, including any calls to
286 ;;; other monitored functions. If functions A and B are monitored,
287 ;;; and A calls B, then the accumulated time and consing for A will
288 ;;; include the time and consing of B. Note: if a function calls
289 ;;; itself recursively, the time spent in the inner call(s) may
290 ;;; be counted several times.
291 ;;; o If :exclusive, the information excludes time attributed to
292 ;;; calls to other monitored functions. This is the default.
293 ;;; - THRESHOLD specifies that only functions which have been executed
294 ;;; more than threshold percent of the time will be reported. Defaults
295 ;;; to 1%. If a threshold of 0 is specified, all functions are listed,
296 ;;; even those with 0 or negative running times (see note on overhead).
297 ;;; - KEY specifies that the table be sorted by one of the following
298 ;;; sort keys:
299 ;;; :function alphabetically by function name
300 ;;; :percent-time by percent of total execution time
301 ;;; :percent-cons by percent of total consing
302 ;;; :calls by number of times the function was called
303 ;;; :time-per-call by average execution time per function
304 ;;; :cons-per-call by average consing per function
305 ;;; :time same as :percent-time
306 ;;; :cons same as :percent-cons
307 ;;;
308 ;;; REPORT &key (names :all) [Function]
309 ;;; (nested :exclusive)
310 ;;; (threshold 0.01)
311 ;;; (sort-key :percent-time)
312 ;;; (ignore-no-calls nil)
313 ;;;
314 ;;; Same as REPORT-MONITORING but we use a nicer keyword interface.
315 ;;;
316 ;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function]
317 ;;; (key :percent-time)
318 ;;; Prints a table showing for each named function:
319 ;;; - the total CPU time used in that function for all calls
320 ;;; - the total number of bytes consed in that function for all calls
321 ;;; - the total number of calls
322 ;;; - the average amount of CPU time per call
323 ;;; - the average amount of consing per call
324 ;;; - the percent of total execution time spent executing that function
325 ;;; - the percent of total consing spent consing in that function
326 ;;; Summary totals of the CPU time, consing, and calls columns are printed.
327 ;;; An estimate of the monitoring overhead is also printed. May be run
328 ;;; even after unmonitoring all the functions, to play with the data.
329 ;;;
330 ;;; SAMPLE TABLE:
331 #|
332 Cons
333 % % Per Total Total
334 Function Time Cons Calls Sec/Call Call Time Cons
335 ----------------------------------------------------------------------
336 FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0
337 GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0
338 GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0
339 FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0
340 ----------------------------------------------------------------------
341 TOTAL: 1173 0.828950 0
342 Estimated total monitoring overhead: 0.88 seconds
343 |#
344
345 ;;; ****************************************************************
346 ;;; METERING *******************************************************
347 ;;; ****************************************************************
348
349 ;;; ********************************
350 ;;; Warn people using the wrong Lisp
351 ;;; ********************************
352
353 #-(or clisp openmcl)
354 (warn "metering.lisp does not support your Lisp implementation!")
355
356 ;;; ********************************
357 ;;; Packages ***********************
358 ;;; ********************************
359
360 ;;; For CLtL2 compatible lisps
361
362 (defpackage "MONITOR" (:nicknames "MON") (:use "COMMON-LISP")
363 (:export "*MONITORED-FUNCTIONS*"
364 "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM"
365 "WITH-MONITORING"
366 "RESET-MONITORING-INFO" "RESET-ALL-MONITORING"
367 "MONITORED"
368 "REPORT-MONITORING"
369 "DISPLAY-MONITORING-RESULTS"
370 "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE"
371 "REPORT"))
372 (in-package "MONITOR")
373
374 ;;; Warn user if they're loading the source instead of compiling it first.
375 (eval-when (eval)
376 (warn "This file should be compiled before loading for best results."))
377
378 ;;; ********************************
379 ;;; Version ************************
380 ;;; ********************************
381
382 (defparameter *metering-version* "v2.1 25-JAN-94"
383 "Current version number/date for Metering.")
384
385
386 ;;; ****************************************************************
387 ;;; Implementation Dependent Definitions ***************************
388 ;;; ****************************************************************
389
390 ;;; ********************************
391 ;;; Timing Functions ***************
392 ;;; ********************************
393 ;;; The get-time function is called to find the total number of ticks since
394 ;;; the beginning of time. time-units-per-second allows us to convert units
395 ;;; to seconds.
396
397 #-(or clisp openmcl)
398 (eval-when (compile eval)
399 (warn
400 "You may want to supply implementation-specific get-time functions."))
401
402 (defconstant time-units-per-second internal-time-units-per-second)
403
404 (defmacro get-time ()
405 `(the time-type (get-internal-run-time)))
406
407 ;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of
408 ;;; milliseconds spent during GC. We could subtract this from
409 ;;; the value returned by get-internal-run-time to eliminate
410 ;;; the effect of GC on the timing values, but we prefer to let
411 ;;; the user run without GC on. If the application is so big that
412 ;;; it requires GC to complete, then the GC times are part of the
413 ;;; cost of doing business, and will average out in the long run.
414 ;;; If it seems really important to a user that GC times not be
415 ;;; counted, then uncomment the following three lines and read-time
416 ;;; conditionalize the definition of get-time above with #-:openmcl.
417 ;#+openmcl
418 ;(defmacro get-time ()
419 ; `(the time-type (- (get-internal-run-time) (ccl:gctime))))
420
421 ;;; ********************************
422 ;;; Consing Functions **************
423 ;;; ********************************
424 ;;; The get-cons macro is called to find the total number of bytes
425 ;;; consed since the beginning of time.
426
427 #+clisp
428 (defun get-cons ()
429 (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
430 (sys::%%time)
431 (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
432 (dpb space1 (byte 24 24) space2)))
433
434 ;;; Macintosh Common Lisp 2.0
435 ;;; Note that this includes bytes that were allocated during GC.
436 ;;; We could subtract this out by advising GC like we did under
437 ;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't
438 ;;; run without GC, then the bytes consed during GC are a cost of
439 ;;; running their program. Metering the code a few times will
440 ;;; avoid the consing values being too lopsided. If a user really really
441 ;;; wants to subtract out the consing during GC, replace the following
442 ;;; two lines with the commented out code.
443 #+openmcl
444 (defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
445 ;; #+openmcl
446 ;; (progn
447 ;; (in-package :ccl)
448 ;; (defvar *bytes-consed-chkpt* 0)
449 ;; (defun reset-consing () (setq *bytes-consed-chkpt* 0))
450 ;; (let ((old-gc (symbol-function 'gc))
451 ;; (ccl:*warn-if-redefine-kernel* nil))
452 ;; (setf (symbol-function 'gc)
453 ;; #'(lambda ()
454 ;; (let ((old-consing (total-bytes-consed)))
455 ;; (prog1
456 ;; (funcall old-gc)
457 ;; (incf *bytes-consed-chkpt*
458 ;; (- old-consing (total-bytes-consed))))))))
459 ;; (defun total-bytes-consed ()
460 ;; "Returns number of conses (8 bytes each)"
461 ;; (ccl::total-bytes-allocated))
462 ;; (in-package "MONITOR")
463 ;; (defun get-cons ()
464 ;; (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*))))
465
466
467 #-(or clisp openmcl)
468 (progn
469 (eval-when (compile eval)
470 (warn "No consing will be reported unless a get-cons function is ~
471 defined."))
472
473 (defmacro get-cons () '(the consing-type 0)))
474
475 ;; actually, neither `get-cons' nor `get-time' are used as is,
476 ;; but only in the following macro `with-time/cons'
477 #-:clisp
478 (defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
479 (let ((start-cons (gensym "START-CONS-"))
480 (start-time (gensym "START-TIME-")))
481 `(let ((,start-time (get-time)) (,start-cons (get-cons)))
482 (declare (type time-type ,start-time)
483 (type consing-type ,start-cons))
484 (multiple-value-prog1 ,form
485 (let ((,delta-time (- (get-time) ,start-time))
486 (,delta-cons (- (get-cons) ,start-cons)))
487 ,@post-process)))))
488
489 #+clisp
490 (progn
491 (defmacro delta4 (nv1 nv2 ov1 ov2 by)
492 `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2))
493
494 (let ((del (find-symbol "DELTA4" "SYS")))
495 (when del (setf (fdefinition 'delta4) (fdefinition del))))
496
497 (if (< internal-time-units-per-second 1000000)
498 ;; TIME_1: AMIGA, OS/2, UNIX_TIMES
499 (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
500 `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16))
501 ;; TIME_2: other UNIX, WIN32
502 (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
503 `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second)
504 (- ,new-time2 ,old-time2))))
505
506 (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2)
507 `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24))
508
509 ;; avoid consing: when the application conses a lot,
510 ;; get-cons may return a bignum, so we really should not use it.
511 (defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
512 (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-"))
513 (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-"))
514 (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-"))
515 (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-"))
516 (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym)))
517 `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2
518 ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) (sys::%%time)
519 (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
520 (multiple-value-prog1 ,form
521 (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2
522 ,gc1 ,gc2 ,end-cons1 ,end-cons2) (sys::%%time)
523 (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
524 (let ((,delta-time (delta4-time ,end-time1 ,end-time2
525 ,beg-time1 ,beg-time2))
526 (,delta-cons (delta4-cons ,end-cons1 ,end-cons2
527 ,beg-cons1 ,beg-cons2)))
528 ,@post-process)))))))
529
530 ;;; ********************************
531 ;;; Required Arguments *************
532 ;;; ********************************
533 ;;;
534 ;;; Required (Fixed) vs Optional Args
535 ;;;
536 ;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
537 ;;; number of required arguments, and use &rest to capture only non-required
538 ;;; arguments. The function Required-Arguments returns two values: the first
539 ;;; is the number of required arguments, and the second is T iff there are any
540 ;;; non-required arguments (e.g. &optional, &rest, &key).
541
542 ;;; Lucid, Allegro, and Macintosh Common Lisp
543 #+openmcl
544 (defun required-arguments (name)
545 (let* ((function (symbol-function name))
546 (args (ccl:arglist function))
547 (pos (position-if #'(lambda (x)
548 (and (symbolp x)
549 (let ((name (symbol-name x)))
550 (and (>= (length name) 1)
551 (char= (schar name 0)
552 #\&)))))
553 args)))
554 (if pos
555 (values pos t)
556 (values (length args) nil))))
557
558 #+clisp
559 (defun required-arguments (name)
560 (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p)
561 (sys::function-signature name t)
562 (if name ; no error
563 (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p))
564 (values 0 t))))
565
566 #-(or clisp openmcl)
567 (progn
568 (eval-when (compile eval)
569 (warn
570 "You may want to add an implementation-specific Required-Arguments function."))
571 (eval-when (load eval)
572 (defun required-arguments (name)
573 (declare (ignore name))
574 (values 0 t))))
575
576 #|
577 ;;;Examples
578 (defun square (x) (* x x))
579 (defun square2 (x &optional y) (* x x y))
580 (defun test (x y &optional (z 3)) 3)
581 (defun test2 (x y &optional (z 3) &rest fred) 3)
582
583 (required-arguments 'square) => 1 nil
584 (required-arguments 'square2) => 1 t
585 (required-arguments 'test) => 2 t
586 (required-arguments 'test2) => 2 t
587 |#
588
589
590 ;;; ****************************************************************
591 ;;; Main METERING Code *********************************************
592 ;;; ****************************************************************
593
594 ;;; ********************************
595 ;;; Global Variables ***************
596 ;;; ********************************
597 (defvar *MONITOR-TIME-OVERHEAD* nil
598 "The amount of time an empty monitored function costs.")
599 (defvar *MONITOR-CONS-OVERHEAD* nil
600 "The amount of cons an empty monitored function costs.")
601
602 (defvar *TOTAL-TIME* 0
603 "Total amount of time monitored so far.")
604 (defvar *TOTAL-CONS* 0
605 "Total amount of consing monitored so far.")
606 (defvar *TOTAL-CALLS* 0
607 "Total number of calls monitored so far.")
608 (proclaim '(type time-type *total-time*))
609 (proclaim '(type consing-type *total-cons*))
610 (proclaim '(fixnum *total-calls*))
611
612 ;;; ********************************
613 ;;; Accessor Functions *************
614 ;;; ********************************
615 ;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables
616 ;;; containing closures.
617 (defmacro PLACE-FUNCTION (function-place)
618 "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
619 if it isn't a symbol, to allow monitoring of closures located in
620 variables/arrays/structures."
621 ;; Note that (fboundp 'fdefinition) returns T even if fdefinition
622 ;; is a macro, which is what we want.
623 (if (fboundp 'fdefinition)
624 `(if (fboundp ,function-place)
625 (fdefinition ,function-place)
626 (eval ,function-place))
627 `(if (symbolp ,function-place)
628 (symbol-function ,function-place)
629 (eval ,function-place))))
630
631 (defsetf PLACE-FUNCTION (function-place) (function)
632 "Set the function in FUNCTION-PLACE to FUNCTION."
633 (if (fboundp 'fdefinition)
634 ;; If we're conforming to CLtL2, use fdefinition here.
635 `(if (fboundp ,function-place)
636 (setf (fdefinition ,function-place) ,function)
637 (eval '(setf ,function-place ',function)))
638 `(if (symbolp ,function-place)
639 (setf (symbol-function ,function-place) ,function)
640 (eval '(setf ,function-place ',function)))))
641
642 #|
643 ;;; before using fdefinition
644 (defun PLACE-FUNCTION (function-place)
645 "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
646 if it isn't a symbol, to allow monitoring of closures located in
647 variables/arrays/structures."
648 (if (symbolp function-place)
649 (symbol-function function-place)
650 (eval function-place)))
651
652 (defsetf PLACE-FUNCTION (function-place) (function)
653 "Set the function in FUNCTION-PLACE to FUNCTION."
654 `(if (symbolp ,function-place)
655 (setf (symbol-function ,function-place) ,function)
656 (eval '(setf ,function-place ',function))))
657 |#
658
659 (defun PLACE-FBOUNDP (function-place)
660 "Test to see if FUNCTION-PLACE is a function."
661 ;; probably should be
662 #|(or (and (symbolp function-place)(fboundp function-place))
663 (functionp (place-function function-place)))|#
664 (if (symbolp function-place)
665 (fboundp function-place)
666 (functionp (place-function function-place))))
667
668 (defun PLACE-MACROP (function-place)
669 "Test to see if FUNCTION-PLACE is a macro."
670 (when (symbolp function-place)
671 (macro-function function-place)))
672
673 ;;; ********************************
674 ;;; Measurement Tables *************
675 ;;; ********************************
676 (defvar *monitored-functions* nil
677 "List of monitored symbols.")
678
679 ;;; We associate a METERING-FUNCTIONS structure with each monitored function
680 ;;; name or other closure. This holds the functions that we call to manipulate
681 ;;; the closure which implements the encapsulation.
682 ;;;
683 (defstruct metering-functions
684 (name nil)
685 (old-definition nil :type function)
686 (new-definition nil :type function)
687 (read-metering nil :type function)
688 (reset-metering nil :type function))
689
690 ;;; In general using hash tables in time-critical programs is a bad idea,
691 ;;; because when one has to grow the table and rehash everything, the
692 ;;; timing becomes grossly inaccurate. In this case it is not an issue
693 ;;; because all inserting of entries in the hash table occurs before the
694 ;;; timing commences. The only circumstance in which this could be a
695 ;;; problem is if the lisp rehashes on the next reference to the table,
696 ;;; instead of when the entry which forces a rehash was inserted.
697 ;;;
698 ;;; Note that a similar kind of problem can occur with GC, which is why
699 ;;; one should turn off GC when monitoring code.
700 ;;;
701 (defvar *monitor* (make-hash-table :test #'equal)
702 "Hash table in which METERING-FUNCTIONS structures are stored.")
703 (defun get-monitor-info (name)
704 (gethash name *monitor*))
705 (defsetf get-monitor-info (name) (info)
706 `(setf (gethash ,name *monitor*) ,info))
707
708 (defun MONITORED (function-place)
709 "Test to see if a FUNCTION-PLACE is monitored."
710 (and (place-fboundp function-place) ; this line necessary?
711 (get-monitor-info function-place)))
712
713 (defun reset-monitoring-info (name)
714 "Reset the monitoring info for the specified function."
715 (let ((finfo (get-monitor-info name)))
716 (when finfo
717 (funcall (metering-functions-reset-metering finfo)))))
718 (defun reset-all-monitoring ()
719 "Reset monitoring info for all functions."
720 (setq *total-time* 0
721 *total-cons* 0
722 *total-calls* 0)
723 (dolist (symbol *monitored-functions*)
724 (when (monitored symbol)
725 (reset-monitoring-info symbol))))
726
727 (defun monitor-info-values (name &optional (nested :exclusive) warn)
728 "Returns monitoring information values for the named function,
729 adjusted for overhead."
730 (let ((finfo (get-monitor-info name)))
731 (if finfo
732 (multiple-value-bind (inclusive-time inclusive-cons
733 exclusive-time exclusive-cons
734 calls nested-calls)
735 (funcall (metering-functions-read-metering finfo))
736 (unless (or (null warn)
737 (eq (place-function name)
738 (metering-functions-new-definition finfo)))
739 (warn "Funtion ~S has been redefined, so times may be inaccurate.~@
740 MONITOR it again to record calls to the new definition."
741 name))
742 (case nested
743 (:exclusive (values calls
744 nested-calls
745 (- exclusive-time
746 (* calls *monitor-time-overhead*))
747 (- exclusive-cons
748 (* calls *monitor-cons-overhead*))))
749 ;; In :inclusive mode, subtract overhead for all the
750 ;; called functions as well. Nested-calls includes the
751 ;; calls of the function as well. [Necessary 'cause of
752 ;; functions which call themselves recursively.]
753 (:inclusive (values calls
754 nested-calls
755 (- inclusive-time
756 (* nested-calls ;(+ calls)
757 *monitor-time-overhead*))
758 (- inclusive-cons
759 (* nested-calls ;(+ calls)
760 *monitor-cons-overhead*))))))
761 (values 0 0 0 0))))
762
763 ;;; ********************************
764 ;;; Encapsulate ********************
765 ;;; ********************************
766 (eval-when (compile load eval)
767 ;; Returns a lambda expression for a function that, when called with the
768 ;; function name, will set up that function for metering.
769 ;;
770 ;; A function is monitored by replacing its definition with a closure
771 ;; created by the following function. The closure records the monitoring
772 ;; data, and updates the data with each call of the function.
773 ;;
774 ;; Other closures are used to read and reset the data.
775 (defun make-monitoring-encapsulation (min-args optionals-p)
776 (let (required-args)
777 (dotimes (i min-args) (push (gensym) required-args))
778 `(lambda (name)
779 (let ((inclusive-time 0)
780 (inclusive-cons 0)
781 (exclusive-time 0)
782 (exclusive-cons 0)
783 (calls 0)
784 (nested-calls 0)
785 (old-definition (place-function name)))
786 (declare (type time-type inclusive-time)
787 (type time-type exclusive-time)
788 (type consing-type inclusive-cons)
789 (type consing-type exclusive-cons)
790 (fixnum calls)
791 (fixnum nested-calls))
792 (pushnew name *monitored-functions*)
793
794 (setf (place-function name)
795 #'(lambda (,@required-args
796 ,@(when optionals-p
797 `(&rest optional-args)))
798 (let ((prev-total-time *total-time*)
799 (prev-total-cons *total-cons*)
800 (prev-total-calls *total-calls*)
801 ;; (old-time inclusive-time)
802 ;; (old-cons inclusive-cons)
803 ;; (old-nested-calls nested-calls)
804 )
805 (declare (type time-type prev-total-time)
806 (type consing-type prev-total-cons)
807 (fixnum prev-total-calls))
808 (with-time/cons (delta-time delta-cons)
809 ;; form
810 ,(if optionals-p
811 `(apply old-definition
812 ,@required-args optional-args)
813 `(funcall old-definition ,@required-args))
814 ;; post-processing:
815 ;; Calls
816 (incf calls)
817 (incf *total-calls*)
818 ;; nested-calls includes this call
819 (incf nested-calls (the fixnum
820 (- *total-calls*
821 prev-total-calls)))
822 ;; (setf nested-calls (+ old-nested-calls
823 ;; (- *total-calls*
824 ;; prev-total-calls)))
825 ;; Time
826 ;; Problem with inclusive time is that it
827 ;; currently doesn't add values from recursive
828 ;; calls to the same function. Change the
829 ;; setf to an incf to fix this?
830 (incf inclusive-time (the time-type delta-time))
831 ;; (setf inclusive-time (+ delta-time old-time))
832 (incf exclusive-time (the time-type
833 (+ delta-time
834 (- prev-total-time
835 *total-time*))))
836 (setf *total-time* (the time-type
837 (+ delta-time
838 prev-total-time)))
839 ;; Consing
840 (incf inclusive-cons (the consing-type delta-cons))
841 ;; (setf inclusive-cons (+ delta-cons old-cons))
842 (incf exclusive-cons (the consing-type
843 (+ delta-cons
844 (- prev-total-cons
845 *total-cons*))))
846 (setf *total-cons*
847 (the consing-type
848 (+ delta-cons prev-total-cons)))))))
849 (setf (get-monitor-info name)
850 (make-metering-functions
851 :name name
852 :old-definition old-definition
853 :new-definition (place-function name)
854 :read-metering #'(lambda ()
855 (values inclusive-time
856 inclusive-cons
857 exclusive-time
858 exclusive-cons
859 calls
860 nested-calls))
861 :reset-metering #'(lambda ()
862 (setq inclusive-time 0
863 inclusive-cons 0
864 exclusive-time 0
865 exclusive-cons 0
866 calls 0
867 nested-calls 0)
868 t)))))))
869 );; End of EVAL-WHEN
870
871 ;;; For efficiency reasons, we precompute the encapsulation functions
872 ;;; for a variety of combinations of argument structures
873 ;;; (min-args . optional-p). These are stored in the following hash table
874 ;;; along with any new ones we encounter. Since we're now precomputing
875 ;;; closure functions for common argument signatures, this eliminates
876 ;;; the former need to call COMPILE for each monitored function.
877 (eval-when (compile eval)
878 (defconstant precomputed-encapsulations 8))
879
880 (defvar *existing-encapsulations* (make-hash-table :test #'equal))
881 (defun find-encapsulation (min-args optionals-p)
882 (or (gethash (cons min-args optionals-p) *existing-encapsulations*)
883 (setf (gethash (cons min-args optionals-p) *existing-encapsulations*)
884 (compile nil
885 (make-monitoring-encapsulation min-args optionals-p)))))
886
887 (macrolet ((frob ()
888 (let ((res ()))
889 (dotimes (i precomputed-encapsulations)
890 (push `(setf (gethash '(,i . nil) *existing-encapsulations*)
891 #',(make-monitoring-encapsulation i nil))
892 res)
893 (push `(setf (gethash '(,i . t) *existing-encapsulations*)
894 #',(make-monitoring-encapsulation i t))
895 res))
896 `(progn ,@res))))
897 (frob))
898
899 (defun monitoring-encapsulate (name &optional warn)
900 "Monitor the function Name. If already monitored, unmonitor first."
901 ;; Saves the current definition of name and inserts a new function which
902 ;; returns the result of evaluating body.
903 (cond ((not (place-fboundp name)) ; not a function
904 (when warn
905 (warn "Ignoring undefined function ~S." name)))
906 ((place-macrop name) ; a macro
907 (when warn
908 (warn "Ignoring macro ~S." name)))
909 (t ; tis a function
910 (when (get-monitor-info name) ; monitored
911 (when warn
912 (warn "~S already monitored, so unmonitoring it first." name))
913 (monitoring-unencapsulate name))
914 (multiple-value-bind (min-args optionals-p)
915 (required-arguments name)
916 (funcall (find-encapsulation min-args optionals-p) name)))))
917
918 (defun monitoring-unencapsulate (name &optional warn)
919 "Removes monitoring encapsulation code from around Name."
920 (let ((finfo (get-monitor-info name)))
921 (when finfo ; monitored
922 (remprop name 'metering-functions)
923 (setq *monitored-functions*
924 (remove name *monitored-functions* :test #'equal))
925 (if (eq (place-function name)
926 (metering-functions-new-definition finfo))
927 (setf (place-function name)
928 (metering-functions-old-definition finfo))
929 (when warn
930 (warn "Preserving current definition of redefined function ~S."
931 name))))))
932
933 ;;; ********************************
934 ;;; Main Monitoring Functions ******
935 ;;; ********************************
936 (defmacro MONITOR (&rest names)
937 "Monitor the named functions. As in TRACE, the names are not evaluated.
938 If a function is already monitored, then unmonitor and remonitor (useful
939 to notice function redefinition). If a name is undefined, give a warning
940 and ignore it. See also unmonitor, report-monitoring,
941 display-monitoring-results and reset-time."
942 `(progn
943 ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names)
944 *monitored-functions*))
945
946 (defmacro UNMONITOR (&rest names)
947 "Remove the monitoring on the named functions.
948 Names defaults to the list of all currently monitored functions."
949 `(dolist (name ,(if names `',names '*monitored-functions*) (values))
950 (monitoring-unencapsulate name)))
951
952 (defun MONITOR-ALL (&optional (package *package*))
953 "Monitor all functions in the specified package."
954 (let ((package (if (packagep package)
955 package
956 (find-package package))))
957 (do-symbols (symbol package)
958 (when (eq (symbol-package symbol) package)
959 (monitoring-encapsulate symbol)))))
960
961 (defmacro MONITOR-FORM (form
962 &optional (nested :exclusive) (threshold 0.01)
963 (key :percent-time))
964 "Monitor the execution of all functions in the current package
965 during the execution of FORM. All functions that are executed above
966 THRESHOLD % will be reported."
967 `(unwind-protect
968 (progn
969 (monitor-all)
970 (reset-all-monitoring)
971 (prog1
972 (time ,form)
973 (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls)))
974 (unmonitor)))
975
976 (defmacro WITH-MONITORING ((&rest functions)
977 (&optional (nested :exclusive)
978 (threshold 0.01)
979 (key :percent-time))
980 &body body)
981 "Monitor the specified functions during the execution of the body."
982 `(unwind-protect
983 (progn
984 (dolist (fun ',functions)
985 (monitoring-encapsulate fun))
986 (reset-all-monitoring)
987 ,@body
988 (report-monitoring :all ,nested ,threshold ,key))
989 (unmonitor)))
990
991 ;;; ********************************
992 ;;; Overhead Calculations **********
993 ;;; ********************************
994 (defconstant overhead-iterations 5000
995 "Number of iterations over which the timing overhead is averaged.")
996
997 ;;; Perhaps this should return something to frustrate clever compilers.
998 (defun STUB-FUNCTION (x)
999 (declare (ignore x))
1000 nil)
1001 (proclaim '(notinline stub-function))
1002
1003 (defun SET-MONITOR-OVERHEAD ()
1004 "Determines the average overhead of monitoring by monitoring the execution
1005 of an empty function many times."
1006 (setq *monitor-time-overhead* 0
1007 *monitor-cons-overhead* 0)
1008 (stub-function nil)
1009 (monitor stub-function)
1010 (reset-all-monitoring)
1011 (let ((overhead-function (symbol-function 'stub-function)))
1012 (dotimes (x overhead-iterations)
1013 (funcall overhead-function overhead-function)))
1014 ; (dotimes (x overhead-iterations)
1015 ; (stub-function nil))
1016 (let ((fiter (float overhead-iterations)))
1017 (multiple-value-bind (calls nested-calls time cons)
1018 (monitor-info-values 'stub-function)
1019 (declare (ignore calls nested-calls))
1020 (setq *monitor-time-overhead* (/ time fiter)
1021 *monitor-cons-overhead* (/ cons fiter))))
1022 (unmonitor stub-function))
1023 (set-monitor-overhead)
1024
1025 ;;; ********************************
1026 ;;; Report Data ********************
1027 ;;; ********************************
1028 (defvar *monitor-results* nil
1029 "A table of monitoring statistics is stored here.")
1030 (defvar *no-calls* nil
1031 "A list of monitored functions which weren't called.")
1032 (defvar *estimated-total-overhead* 0)
1033 ;; (proclaim '(type time-type *estimated-total-overhead*))
1034
1035 (defstruct (monitoring-info
1036 (:conc-name m-info-)
1037 (:constructor make-monitoring-info
1038 (name calls time cons
1039 percent-time percent-cons
1040 time-per-call cons-per-call)))
1041 name
1042 calls
1043 time
1044 cons
1045 percent-time
1046 percent-cons
1047 time-per-call
1048 cons-per-call)
1049
1050 (defun REPORT (&key (names :all)
1051 (nested :exclusive)
1052 (threshold 0.01)
1053 (sort-key :percent-time)
1054 (ignore-no-calls nil))
1055 "Same as REPORT-MONITORING but with a nicer keyword interface"
1056 (declare (type (member :function :percent-time :time :percent-cons
1057 :cons :calls :time-per-call :cons-per-call)
1058 sort-key)
1059 (type (member :inclusive :exclusive) nested))
1060 (report-monitoring names nested threshold sort-key ignore-no-calls))
1061
1062 (defun REPORT-MONITORING (&optional names
1063 (nested :exclusive)
1064 (threshold 0.01)
1065 (key :percent-time)
1066 ignore-no-calls)
1067 "Report the current monitoring state.
1068 The percentage of the total time spent executing unmonitored code
1069 in each function (:exclusive mode), or total time (:inclusive mode)
1070 will be printed together with the number of calls and
1071 the unmonitored time per call. Functions that have been executed
1072 below THRESHOLD % of the time will not be reported. To report on all
1073 functions set NAMES to be either NIL or :ALL."
1074 (when (or (null names) (eq names :all)) (setq names *monitored-functions*))
1075
1076 (let ((total-time 0)
1077 (total-cons 0)
1078 (total-calls 0))
1079 ;; Compute overall time and consing.
1080 (dolist (name names)
1081 (multiple-value-bind (calls nested-calls time cons)
1082 (monitor-info-values name nested :warn)
1083 (declare (ignore nested-calls))
1084 (incf total-calls calls)
1085 (incf total-time time)
1086 (incf total-cons cons)))
1087 ;; Total overhead.
1088 (setq *estimated-total-overhead*
1089 (/ (* *monitor-time-overhead* total-calls)
1090 time-units-per-second))
1091 ;; Assemble data for only the specified names (all monitored functions)
1092 (if (zerop total-time)
1093 (format *trace-output* "Not enough execution time to monitor.")
1094 (progn
1095 (setq *monitor-results* nil *no-calls* nil)
1096 (dolist (name names)
1097 (multiple-value-bind (calls nested-calls time cons)
1098 (monitor-info-values name nested)
1099 (declare (ignore nested-calls))
1100 (when (minusp time) (setq time 0.0))
1101 (when (minusp cons) (setq cons 0.0))
1102 (if (zerop calls)
1103 (push (if (symbolp name)
1104 (symbol-name name)
1105 (format nil "~S" name))
1106 *no-calls*)
1107 (push (make-monitoring-info
1108 (format nil "~S" name) ; name
1109 calls ; calls
1110 (/ time (float time-units-per-second)) ; time in secs
1111 (round cons) ; consing
1112 (/ time (float total-time)) ; percent-time
1113 (if (zerop total-cons) 0
1114 (/ cons (float total-cons))) ; percent-cons
1115 (/ (/ time (float calls)) ; time-per-call
1116 time-units-per-second) ; sec/call
1117 (round (/ cons (float calls)))) ; cons-per-call
1118 *monitor-results*))))
1119 (display-monitoring-results threshold key ignore-no-calls)))))
1120
1121 (defun display-monitoring-results (&optional (threshold 0.01) (key :percent-time)
1122 (ignore-no-calls t))
1123 (let ((max-length 8) ; Function header size
1124 (max-cons-length 8)
1125 (total-time 0.0)
1126 (total-consed 0)
1127 (total-calls 0)
1128 (total-percent-time 0)
1129 (total-percent-cons 0))
1130 (sort-results key)
1131 (dolist (result *monitor-results*)
1132 (when (or (zerop threshold)
1133 (> (m-info-percent-time result) threshold))
1134 (setq max-length
1135 (max max-length
1136 (length (m-info-name result))))
1137 (setq max-cons-length
1138 (max max-cons-length
1139 (m-info-cons-per-call result)))))
1140 (incf max-length 2)
1141 (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10))))
1142 (format *trace-output*
1143 "~%~%~
1144 ~VT ~VA~
1145 ~% ~VT % % ~VA Total Total~
1146 ~%Function~VT Time Cons Calls Sec/Call ~VA Time Cons~
1147 ~%~V,,,'-A"
1148 max-length
1149 max-cons-length "Cons"
1150 max-length
1151 max-cons-length "Per"
1152 max-length
1153 max-cons-length "Call"
1154 (+ max-length 62 (max 0 (- max-cons-length 5))) "-")
1155 (dolist (result *monitor-results*)
1156 (when (or (zerop threshold)
1157 (> (m-info-percent-time result) threshold))
1158 (format *trace-output*
1159 "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D"
1160 (m-info-name result)
1161 max-length
1162 (* 100 (m-info-percent-time result))
1163 (* 100 (m-info-percent-cons result))
1164 (m-info-calls result)
1165 (m-info-time-per-call result)
1166 max-cons-length
1167 (m-info-cons-per-call result)
1168 (m-info-time result)
1169 (m-info-cons result))
1170 (incf total-time (m-info-time result))
1171 (incf total-consed (m-info-cons result))
1172 (incf total-calls (m-info-calls result))
1173 (incf total-percent-time (m-info-percent-time result))
1174 (incf total-percent-cons (m-info-percent-cons result))))
1175 (format *trace-output*
1176 "~%~V,,,'-A~
1177 ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~
1178 ~%Estimated monitoring overhead: ~5,2F seconds~
1179 ~%Estimated total monitoring overhead: ~5,2F seconds"
1180 (+ max-length 62 (max 0 (- max-cons-length 5))) "-"
1181 max-length
1182 (* 100 total-percent-time)
1183 (* 100 total-percent-cons)
1184 total-calls
1185 max-cons-length " "
1186 total-time total-consed
1187 (/ (* *monitor-time-overhead* total-calls)
1188 time-units-per-second)
1189 *estimated-total-overhead*)
1190 (when (and (not ignore-no-calls) *no-calls*)
1191 (setq *no-calls* (sort *no-calls* #'string<))
1192 (let ((num-no-calls (length *no-calls*)))
1193 (if (> num-no-calls 20)
1194 (format *trace-output*
1195 "~%~@(~r~) monitored functions were not called. ~
1196 ~%See the variable mon::*no-calls* for a list."
1197 num-no-calls)
1198 (format *trace-output*
1199 "~%The following monitored functions were not called:~
1200 ~%~{~<~%~:; ~A~>~}~%"
1201 *no-calls*))))
1202 (values)))
1203
1204 (defun sort-results (&optional (key :percent-time))
1205 (setq *monitor-results*
1206 (case key
1207 (:function (sort *monitor-results* #'string>
1208 :key #'m-info-name))
1209 ((:percent-time :time) (sort *monitor-results* #'>
1210 :key #'m-info-time))
1211 ((:percent-cons :cons) (sort *monitor-results* #'>
1212 :key #'m-info-cons))
1213 (:calls (sort *monitor-results* #'>
1214 :key #'m-info-calls))
1215 (:time-per-call (sort *monitor-results* #'>
1216 :key #'m-info-time-per-call))
1217 (:cons-per-call (sort *monitor-results* #'>
1218 :key #'m-info-cons-per-call)))))
1219
1220 ;;; *END OF FILE*
1221
1222

  ViewVC Help
Powered by ViewVC 1.1.5