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

Contents of /slime/metering.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5