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

Contents of /slime/metering.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Fri Aug 22 21:15:07 2008 UTC (5 years, 7 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-2-3, SLIME-2-2, byte-stream, FAIRLY-STABLE
Changes since 1.4: +6 -1 lines
* metering.lisp: Add deftypes for time-type and cons-type, which
are not defined in newer versions of CCL.
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 ;;;
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 #+openmcl
405 (progn
406 (deftype time-type () 'unsigned-byte)
407 (deftype consing-type () 'unsigned-byte))
408
409 (defmacro get-time ()
410 `(the time-type (get-internal-run-time)))
411
412 ;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of
413 ;;; milliseconds spent during GC. We could subtract this from
414 ;;; the value returned by get-internal-run-time to eliminate
415 ;;; the effect of GC on the timing values, but we prefer to let
416 ;;; the user run without GC on. If the application is so big that
417 ;;; it requires GC to complete, then the GC times are part of the
418 ;;; cost of doing business, and will average out in the long run.
419 ;;; If it seems really important to a user that GC times not be
420 ;;; counted, then uncomment the following three lines and read-time
421 ;;; conditionalize the definition of get-time above with #-:openmcl.
422 ;#+openmcl
423 ;(defmacro get-time ()
424 ; `(the time-type (- (get-internal-run-time) (ccl:gctime))))
425
426 ;;; ********************************
427 ;;; Consing Functions **************
428 ;;; ********************************
429 ;;; The get-cons macro is called to find the total number of bytes
430 ;;; consed since the beginning of time.
431
432 #+clisp
433 (defun get-cons ()
434 (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
435 (sys::%%time)
436 (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
437 (dpb space1 (byte 24 24) space2)))
438
439 ;;; Macintosh Common Lisp 2.0
440 ;;; Note that this includes bytes that were allocated during GC.
441 ;;; We could subtract this out by advising GC like we did under
442 ;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't
443 ;;; run without GC, then the bytes consed during GC are a cost of
444 ;;; running their program. Metering the code a few times will
445 ;;; avoid the consing values being too lopsided. If a user really really
446 ;;; wants to subtract out the consing during GC, replace the following
447 ;;; two lines with the commented out code.
448 #+openmcl
449 (defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
450 ;; #+openmcl
451 ;; (progn
452 ;; (in-package :ccl)
453 ;; (defvar *bytes-consed-chkpt* 0)
454 ;; (defun reset-consing () (setq *bytes-consed-chkpt* 0))
455 ;; (let ((old-gc (symbol-function 'gc))
456 ;; (ccl:*warn-if-redefine-kernel* nil))
457 ;; (setf (symbol-function 'gc)
458 ;; #'(lambda ()
459 ;; (let ((old-consing (total-bytes-consed)))
460 ;; (prog1
461 ;; (funcall old-gc)
462 ;; (incf *bytes-consed-chkpt*
463 ;; (- old-consing (total-bytes-consed))))))))
464 ;; (defun total-bytes-consed ()
465 ;; "Returns number of conses (8 bytes each)"
466 ;; (ccl::total-bytes-allocated))
467 ;; (in-package "MONITOR")
468 ;; (defun get-cons ()
469 ;; (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*))))
470
471
472 #-(or clisp openmcl)
473 (progn
474 (eval-when (compile eval)
475 (warn "No consing will be reported unless a get-cons function is ~
476 defined."))
477
478 (defmacro get-cons () '(the consing-type 0)))
479
480 ;; actually, neither `get-cons' nor `get-time' are used as is,
481 ;; but only in the following macro `with-time/cons'
482 #-:clisp
483 (defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
484 (let ((start-cons (gensym "START-CONS-"))
485 (start-time (gensym "START-TIME-")))
486 `(let ((,start-time (get-time)) (,start-cons (get-cons)))
487 (declare (type time-type ,start-time)
488 (type consing-type ,start-cons))
489 (multiple-value-prog1 ,form
490 (let ((,delta-time (- (get-time) ,start-time))
491 (,delta-cons (- (get-cons) ,start-cons)))
492 ,@post-process)))))
493
494 #+clisp
495 (progn
496 (defmacro delta4 (nv1 nv2 ov1 ov2 by)
497 `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2))
498
499 (let ((del (find-symbol "DELTA4" "SYS")))
500 (when del (setf (fdefinition 'delta4) (fdefinition del))))
501
502 (if (< internal-time-units-per-second 1000000)
503 ;; TIME_1: AMIGA, OS/2, UNIX_TIMES
504 (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
505 `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16))
506 ;; TIME_2: other UNIX, WIN32
507 (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
508 `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second)
509 (- ,new-time2 ,old-time2))))
510
511 (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2)
512 `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24))
513
514 ;; avoid consing: when the application conses a lot,
515 ;; get-cons may return a bignum, so we really should not use it.
516 (defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
517 (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-"))
518 (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-"))
519 (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-"))
520 (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-"))
521 (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym)))
522 `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2
523 ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) (sys::%%time)
524 (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
525 (multiple-value-prog1 ,form
526 (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2
527 ,gc1 ,gc2 ,end-cons1 ,end-cons2) (sys::%%time)
528 (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
529 (let ((,delta-time (delta4-time ,end-time1 ,end-time2
530 ,beg-time1 ,beg-time2))
531 (,delta-cons (delta4-cons ,end-cons1 ,end-cons2
532 ,beg-cons1 ,beg-cons2)))
533 ,@post-process)))))))
534
535 ;;; ********************************
536 ;;; Required Arguments *************
537 ;;; ********************************
538 ;;;
539 ;;; Required (Fixed) vs Optional Args
540 ;;;
541 ;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
542 ;;; number of required arguments, and use &rest to capture only non-required
543 ;;; arguments. The function Required-Arguments returns two values: the first
544 ;;; is the number of required arguments, and the second is T iff there are any
545 ;;; non-required arguments (e.g. &optional, &rest, &key).
546
547 ;;; Lucid, Allegro, and Macintosh Common Lisp
548 #+openmcl
549 (defun required-arguments (name)
550 (let* ((function (symbol-function name))
551 (args (ccl:arglist function))
552 (pos (position-if #'(lambda (x)
553 (and (symbolp x)
554 (let ((name (symbol-name x)))
555 (and (>= (length name) 1)
556 (char= (schar name 0)
557 #\&)))))
558 args)))
559 (if pos
560 (values pos t)
561 (values (length args) nil))))
562
563 #+clisp
564 (defun required-arguments (name)
565 (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p)
566 (sys::function-signature name t)
567 (if name ; no error
568 (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p))
569 (values 0 t))))
570
571 #-(or clisp openmcl)
572 (progn
573 (eval-when (compile eval)
574 (warn
575 "You may want to add an implementation-specific Required-Arguments function."))
576 (eval-when (load eval)
577 (defun required-arguments (name)
578 (declare (ignore name))
579 (values 0 t))))
580
581 #|
582 ;;;Examples
583 (defun square (x) (* x x))
584 (defun square2 (x &optional y) (* x x y))
585 (defun test (x y &optional (z 3)) 3)
586 (defun test2 (x y &optional (z 3) &rest fred) 3)
587
588 (required-arguments 'square) => 1 nil
589 (required-arguments 'square2) => 1 t
590 (required-arguments 'test) => 2 t
591 (required-arguments 'test2) => 2 t
592 |#
593
594
595 ;;; ****************************************************************
596 ;;; Main METERING Code *********************************************
597 ;;; ****************************************************************
598
599 ;;; ********************************
600 ;;; Global Variables ***************
601 ;;; ********************************
602 (defvar *MONITOR-TIME-OVERHEAD* nil
603 "The amount of time an empty monitored function costs.")
604 (defvar *MONITOR-CONS-OVERHEAD* nil
605 "The amount of cons an empty monitored function costs.")
606
607 (defvar *TOTAL-TIME* 0
608 "Total amount of time monitored so far.")
609 (defvar *TOTAL-CONS* 0
610 "Total amount of consing monitored so far.")
611 (defvar *TOTAL-CALLS* 0
612 "Total number of calls monitored so far.")
613 (proclaim '(type time-type *total-time*))
614 (proclaim '(type consing-type *total-cons*))
615 (proclaim '(fixnum *total-calls*))
616
617 ;;; ********************************
618 ;;; Accessor Functions *************
619 ;;; ********************************
620 ;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables
621 ;;; containing closures.
622 (defmacro PLACE-FUNCTION (function-place)
623 "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
624 if it isn't a symbol, to allow monitoring of closures located in
625 variables/arrays/structures."
626 ;; Note that (fboundp 'fdefinition) returns T even if fdefinition
627 ;; is a macro, which is what we want.
628 (if (fboundp 'fdefinition)
629 `(if (fboundp ,function-place)
630 (fdefinition ,function-place)
631 (eval ,function-place))
632 `(if (symbolp ,function-place)
633 (symbol-function ,function-place)
634 (eval ,function-place))))
635
636 (defsetf PLACE-FUNCTION (function-place) (function)
637 "Set the function in FUNCTION-PLACE to FUNCTION."
638 (if (fboundp 'fdefinition)
639 ;; If we're conforming to CLtL2, use fdefinition here.
640 `(if (fboundp ,function-place)
641 (setf (fdefinition ,function-place) ,function)
642 (eval '(setf ,function-place ',function)))
643 `(if (symbolp ,function-place)
644 (setf (symbol-function ,function-place) ,function)
645 (eval '(setf ,function-place ',function)))))
646
647 #|
648 ;;; before using fdefinition
649 (defun PLACE-FUNCTION (function-place)
650 "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
651 if it isn't a symbol, to allow monitoring of closures located in
652 variables/arrays/structures."
653 (if (symbolp function-place)
654 (symbol-function function-place)
655 (eval function-place)))
656
657 (defsetf PLACE-FUNCTION (function-place) (function)
658 "Set the function in FUNCTION-PLACE to FUNCTION."
659 `(if (symbolp ,function-place)
660 (setf (symbol-function ,function-place) ,function)
661 (eval '(setf ,function-place ',function))))
662 |#
663
664 (defun PLACE-FBOUNDP (function-place)
665 "Test to see if FUNCTION-PLACE is a function."
666 ;; probably should be
667 #|(or (and (symbolp function-place)(fboundp function-place))
668 (functionp (place-function function-place)))|#
669 (if (symbolp function-place)
670 (fboundp function-place)
671 (functionp (place-function function-place))))
672
673 (defun PLACE-MACROP (function-place)
674 "Test to see if FUNCTION-PLACE is a macro."
675 (when (symbolp function-place)
676 (macro-function function-place)))
677
678 ;;; ********************************
679 ;;; Measurement Tables *************
680 ;;; ********************************
681 (defvar *monitored-functions* nil
682 "List of monitored symbols.")
683
684 ;;; We associate a METERING-FUNCTIONS structure with each monitored function
685 ;;; name or other closure. This holds the functions that we call to manipulate
686 ;;; the closure which implements the encapsulation.
687 ;;;
688 (defstruct metering-functions
689 (name nil)
690 (old-definition nil :type function)
691 (new-definition nil :type function)
692 (read-metering nil :type function)
693 (reset-metering nil :type function))
694
695 ;;; In general using hash tables in time-critical programs is a bad idea,
696 ;;; because when one has to grow the table and rehash everything, the
697 ;;; timing becomes grossly inaccurate. In this case it is not an issue
698 ;;; because all inserting of entries in the hash table occurs before the
699 ;;; timing commences. The only circumstance in which this could be a
700 ;;; problem is if the lisp rehashes on the next reference to the table,
701 ;;; instead of when the entry which forces a rehash was inserted.
702 ;;;
703 ;;; Note that a similar kind of problem can occur with GC, which is why
704 ;;; one should turn off GC when monitoring code.
705 ;;;
706 (defvar *monitor* (make-hash-table :test #'equal)
707 "Hash table in which METERING-FUNCTIONS structures are stored.")
708 (defun get-monitor-info (name)
709 (gethash name *monitor*))
710 (defsetf get-monitor-info (name) (info)
711 `(setf (gethash ,name *monitor*) ,info))
712
713 (defun MONITORED (function-place)
714 "Test to see if a FUNCTION-PLACE is monitored."
715 (and (place-fboundp function-place) ; this line necessary?
716 (get-monitor-info function-place)))
717
718 (defun reset-monitoring-info (name)
719 "Reset the monitoring info for the specified function."
720 (let ((finfo (get-monitor-info name)))
721 (when finfo
722 (funcall (metering-functions-reset-metering finfo)))))
723 (defun reset-all-monitoring ()
724 "Reset monitoring info for all functions."
725 (setq *total-time* 0
726 *total-cons* 0
727 *total-calls* 0)
728 (dolist (symbol *monitored-functions*)
729 (when (monitored symbol)
730 (reset-monitoring-info symbol))))
731
732 (defun monitor-info-values (name &optional (nested :exclusive) warn)
733 "Returns monitoring information values for the named function,
734 adjusted for overhead."
735 (let ((finfo (get-monitor-info name)))
736 (if finfo
737 (multiple-value-bind (inclusive-time inclusive-cons
738 exclusive-time exclusive-cons
739 calls nested-calls)
740 (funcall (metering-functions-read-metering finfo))
741 (unless (or (null warn)
742 (eq (place-function name)
743 (metering-functions-new-definition finfo)))
744 (warn "Funtion ~S has been redefined, so times may be inaccurate.~@
745 MONITOR it again to record calls to the new definition."
746 name))
747 (case nested
748 (:exclusive (values calls
749 nested-calls
750 (- exclusive-time
751 (* calls *monitor-time-overhead*))
752 (- exclusive-cons
753 (* calls *monitor-cons-overhead*))))
754 ;; In :inclusive mode, subtract overhead for all the
755 ;; called functions as well. Nested-calls includes the
756 ;; calls of the function as well. [Necessary 'cause of
757 ;; functions which call themselves recursively.]
758 (:inclusive (values calls
759 nested-calls
760 (- inclusive-time
761 (* nested-calls ;(+ calls)
762 *monitor-time-overhead*))
763 (- inclusive-cons
764 (* nested-calls ;(+ calls)
765 *monitor-cons-overhead*))))))
766 (values 0 0 0 0))))
767
768 ;;; ********************************
769 ;;; Encapsulate ********************
770 ;;; ********************************
771 (eval-when (compile load eval)
772 ;; Returns a lambda expression for a function that, when called with the
773 ;; function name, will set up that function for metering.
774 ;;
775 ;; A function is monitored by replacing its definition with a closure
776 ;; created by the following function. The closure records the monitoring
777 ;; data, and updates the data with each call of the function.
778 ;;
779 ;; Other closures are used to read and reset the data.
780 (defun make-monitoring-encapsulation (min-args optionals-p)
781 (let (required-args)
782 (dotimes (i min-args) (push (gensym) required-args))
783 `(lambda (name)
784 (let ((inclusive-time 0)
785 (inclusive-cons 0)
786 (exclusive-time 0)
787 (exclusive-cons 0)
788 (calls 0)
789 (nested-calls 0)
790 (old-definition (place-function name)))
791 (declare (type time-type inclusive-time)
792 (type time-type exclusive-time)
793 (type consing-type inclusive-cons)
794 (type consing-type exclusive-cons)
795 (fixnum calls)
796 (fixnum nested-calls))
797 (pushnew name *monitored-functions*)
798
799 (setf (place-function name)
800 #'(lambda (,@required-args
801 ,@(when optionals-p
802 `(&rest optional-args)))
803 (let ((prev-total-time *total-time*)
804 (prev-total-cons *total-cons*)
805 (prev-total-calls *total-calls*)
806 ;; (old-time inclusive-time)
807 ;; (old-cons inclusive-cons)
808 ;; (old-nested-calls nested-calls)
809 )
810 (declare (type time-type prev-total-time)
811 (type consing-type prev-total-cons)
812 (fixnum prev-total-calls))
813 (with-time/cons (delta-time delta-cons)
814 ;; form
815 ,(if optionals-p
816 `(apply old-definition
817 ,@required-args optional-args)
818 `(funcall old-definition ,@required-args))
819 ;; post-processing:
820 ;; Calls
821 (incf calls)
822 (incf *total-calls*)
823 ;; nested-calls includes this call
824 (incf nested-calls (the fixnum
825 (- *total-calls*
826 prev-total-calls)))
827 ;; (setf nested-calls (+ old-nested-calls
828 ;; (- *total-calls*
829 ;; prev-total-calls)))
830 ;; Time
831 ;; Problem with inclusive time is that it
832 ;; currently doesn't add values from recursive
833 ;; calls to the same function. Change the
834 ;; setf to an incf to fix this?
835 (incf inclusive-time (the time-type delta-time))
836 ;; (setf inclusive-time (+ delta-time old-time))
837 (incf exclusive-time (the time-type
838 (+ delta-time
839 (- prev-total-time
840 *total-time*))))
841 (setf *total-time* (the time-type
842 (+ delta-time
843 prev-total-time)))
844 ;; Consing
845 (incf inclusive-cons (the consing-type delta-cons))
846 ;; (setf inclusive-cons (+ delta-cons old-cons))
847 (incf exclusive-cons (the consing-type
848 (+ delta-cons
849 (- prev-total-cons
850 *total-cons*))))
851 (setf *total-cons*
852 (the consing-type
853 (+ delta-cons prev-total-cons)))))))
854 (setf (get-monitor-info name)
855 (make-metering-functions
856 :name name
857 :old-definition old-definition
858 :new-definition (place-function name)
859 :read-metering #'(lambda ()
860 (values inclusive-time
861 inclusive-cons
862 exclusive-time
863 exclusive-cons
864 calls
865 nested-calls))
866 :reset-metering #'(lambda ()
867 (setq inclusive-time 0
868 inclusive-cons 0
869 exclusive-time 0
870 exclusive-cons 0
871 calls 0
872 nested-calls 0)
873 t)))))))
874 );; End of EVAL-WHEN
875
876 ;;; For efficiency reasons, we precompute the encapsulation functions
877 ;;; for a variety of combinations of argument structures
878 ;;; (min-args . optional-p). These are stored in the following hash table
879 ;;; along with any new ones we encounter. Since we're now precomputing
880 ;;; closure functions for common argument signatures, this eliminates
881 ;;; the former need to call COMPILE for each monitored function.
882 (eval-when (compile eval)
883 (defconstant precomputed-encapsulations 8))
884
885 (defvar *existing-encapsulations* (make-hash-table :test #'equal))
886 (defun find-encapsulation (min-args optionals-p)
887 (or (gethash (cons min-args optionals-p) *existing-encapsulations*)
888 (setf (gethash (cons min-args optionals-p) *existing-encapsulations*)
889 (compile nil
890 (make-monitoring-encapsulation min-args optionals-p)))))
891
892 (macrolet ((frob ()
893 (let ((res ()))
894 (dotimes (i precomputed-encapsulations)
895 (push `(setf (gethash '(,i . nil) *existing-encapsulations*)
896 #',(make-monitoring-encapsulation i nil))
897 res)
898 (push `(setf (gethash '(,i . t) *existing-encapsulations*)
899 #',(make-monitoring-encapsulation i t))
900 res))
901 `(progn ,@res))))
902 (frob))
903
904 (defun monitoring-encapsulate (name &optional warn)
905 "Monitor the function Name. If already monitored, unmonitor first."
906 ;; Saves the current definition of name and inserts a new function which
907 ;; returns the result of evaluating body.
908 (cond ((not (place-fboundp name)) ; not a function
909 (when warn
910 (warn "Ignoring undefined function ~S." name)))
911 ((place-macrop name) ; a macro
912 (when warn
913 (warn "Ignoring macro ~S." name)))
914 (t ; tis a function
915 (when (get-monitor-info name) ; monitored
916 (when warn
917 (warn "~S already monitored, so unmonitoring it first." name))
918 (monitoring-unencapsulate name))
919 (multiple-value-bind (min-args optionals-p)
920 (required-arguments name)
921 (funcall (find-encapsulation min-args optionals-p) name)))))
922
923 (defun monitoring-unencapsulate (name &optional warn)
924 "Removes monitoring encapsulation code from around Name."
925 (let ((finfo (get-monitor-info name)))
926 (when finfo ; monitored
927 (remprop name 'metering-functions)
928 (setq *monitored-functions*
929 (remove name *monitored-functions* :test #'equal))
930 (if (eq (place-function name)
931 (metering-functions-new-definition finfo))
932 (setf (place-function name)
933 (metering-functions-old-definition finfo))
934 (when warn
935 (warn "Preserving current definition of redefined function ~S."
936 name))))))
937
938 ;;; ********************************
939 ;;; Main Monitoring Functions ******
940 ;;; ********************************
941 (defmacro MONITOR (&rest names)
942 "Monitor the named functions. As in TRACE, the names are not evaluated.
943 If a function is already monitored, then unmonitor and remonitor (useful
944 to notice function redefinition). If a name is undefined, give a warning
945 and ignore it. See also unmonitor, report-monitoring,
946 display-monitoring-results and reset-time."
947 `(progn
948 ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names)
949 *monitored-functions*))
950
951 (defmacro UNMONITOR (&rest names)
952 "Remove the monitoring on the named functions.
953 Names defaults to the list of all currently monitored functions."
954 `(dolist (name ,(if names `',names '*monitored-functions*) (values))
955 (monitoring-unencapsulate name)))
956
957 (defun MONITOR-ALL (&optional (package *package*))
958 "Monitor all functions in the specified package."
959 (let ((package (if (packagep package)
960 package
961 (find-package package))))
962 (do-symbols (symbol package)
963 (when (eq (symbol-package symbol) package)
964 (monitoring-encapsulate symbol)))))
965
966 (defmacro MONITOR-FORM (form
967 &optional (nested :exclusive) (threshold 0.01)
968 (key :percent-time))
969 "Monitor the execution of all functions in the current package
970 during the execution of FORM. All functions that are executed above
971 THRESHOLD % will be reported."
972 `(unwind-protect
973 (progn
974 (monitor-all)
975 (reset-all-monitoring)
976 (prog1
977 (time ,form)
978 (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls)))
979 (unmonitor)))
980
981 (defmacro WITH-MONITORING ((&rest functions)
982 (&optional (nested :exclusive)
983 (threshold 0.01)
984 (key :percent-time))
985 &body body)
986 "Monitor the specified functions during the execution of the body."
987 `(unwind-protect
988 (progn
989 (dolist (fun ',functions)
990 (monitoring-encapsulate fun))
991 (reset-all-monitoring)
992 ,@body
993 (report-monitoring :all ,nested ,threshold ,key))
994 (unmonitor)))
995
996 ;;; ********************************
997 ;;; Overhead Calculations **********
998 ;;; ********************************
999 (defconstant overhead-iterations 5000
1000 "Number of iterations over which the timing overhead is averaged.")
1001
1002 ;;; Perhaps this should return something to frustrate clever compilers.
1003 (defun STUB-FUNCTION (x)
1004 (declare (ignore x))
1005 nil)
1006 (proclaim '(notinline stub-function))
1007
1008 (defun SET-MONITOR-OVERHEAD ()
1009 "Determines the average overhead of monitoring by monitoring the execution
1010 of an empty function many times."
1011 (setq *monitor-time-overhead* 0
1012 *monitor-cons-overhead* 0)
1013 (stub-function nil)
1014 (monitor stub-function)
1015 (reset-all-monitoring)
1016 (let ((overhead-function (symbol-function 'stub-function)))
1017 (dotimes (x overhead-iterations)
1018 (funcall overhead-function overhead-function)))
1019 ; (dotimes (x overhead-iterations)
1020 ; (stub-function nil))
1021 (let ((fiter (float overhead-iterations)))
1022 (multiple-value-bind (calls nested-calls time cons)
1023 (monitor-info-values 'stub-function)
1024 (declare (ignore calls nested-calls))
1025 (setq *monitor-time-overhead* (/ time fiter)
1026 *monitor-cons-overhead* (/ cons fiter))))
1027 (unmonitor stub-function))
1028 (set-monitor-overhead)
1029
1030 ;;; ********************************
1031 ;;; Report Data ********************
1032 ;;; ********************************
1033 (defvar *monitor-results* nil
1034 "A table of monitoring statistics is stored here.")
1035 (defvar *no-calls* nil
1036 "A list of monitored functions which weren't called.")
1037 (defvar *estimated-total-overhead* 0)
1038 ;; (proclaim '(type time-type *estimated-total-overhead*))
1039
1040 (defstruct (monitoring-info
1041 (:conc-name m-info-)
1042 (:constructor make-monitoring-info
1043 (name calls time cons
1044 percent-time percent-cons
1045 time-per-call cons-per-call)))
1046 name
1047 calls
1048 time
1049 cons
1050 percent-time
1051 percent-cons
1052 time-per-call
1053 cons-per-call)
1054
1055 (defun REPORT (&key (names :all)
1056 (nested :exclusive)
1057 (threshold 0.01)
1058 (sort-key :percent-time)
1059 (ignore-no-calls nil))
1060 "Same as REPORT-MONITORING but with a nicer keyword interface"
1061 (declare (type (member :function :percent-time :time :percent-cons
1062 :cons :calls :time-per-call :cons-per-call)
1063 sort-key)
1064 (type (member :inclusive :exclusive) nested))
1065 (report-monitoring names nested threshold sort-key ignore-no-calls))
1066
1067 (defun REPORT-MONITORING (&optional names
1068 (nested :exclusive)
1069 (threshold 0.01)
1070 (key :percent-time)
1071 ignore-no-calls)
1072 "Report the current monitoring state.
1073 The percentage of the total time spent executing unmonitored code
1074 in each function (:exclusive mode), or total time (:inclusive mode)
1075 will be printed together with the number of calls and
1076 the unmonitored time per call. Functions that have been executed
1077 below THRESHOLD % of the time will not be reported. To report on all
1078 functions set NAMES to be either NIL or :ALL."
1079 (when (or (null names) (eq names :all)) (setq names *monitored-functions*))
1080
1081 (let ((total-time 0)
1082 (total-cons 0)
1083 (total-calls 0))
1084 ;; Compute overall time and consing.
1085 (dolist (name names)
1086 (multiple-value-bind (calls nested-calls time cons)
1087 (monitor-info-values name nested :warn)
1088 (declare (ignore nested-calls))
1089 (incf total-calls calls)
1090 (incf total-time time)
1091 (incf total-cons cons)))
1092 ;; Total overhead.
1093 (setq *estimated-total-overhead*
1094 (/ (* *monitor-time-overhead* total-calls)
1095 time-units-per-second))
1096 ;; Assemble data for only the specified names (all monitored functions)
1097 (if (zerop total-time)
1098 (format *trace-output* "Not enough execution time to monitor.")
1099 (progn
1100 (setq *monitor-results* nil *no-calls* nil)
1101 (dolist (name names)
1102 (multiple-value-bind (calls nested-calls time cons)
1103 (monitor-info-values name nested)
1104 (declare (ignore nested-calls))
1105 (when (minusp time) (setq time 0.0))
1106 (when (minusp cons) (setq cons 0.0))
1107 (if (zerop calls)
1108 (push (if (symbolp name)
1109 (symbol-name name)
1110 (format nil "~S" name))
1111 *no-calls*)
1112 (push (make-monitoring-info
1113 (format nil "~S" name) ; name
1114 calls ; calls
1115 (/ time (float time-units-per-second)) ; time in secs
1116 (round cons) ; consing
1117 (/ time (float total-time)) ; percent-time
1118 (if (zerop total-cons) 0
1119 (/ cons (float total-cons))) ; percent-cons
1120 (/ (/ time (float calls)) ; time-per-call
1121 time-units-per-second) ; sec/call
1122 (round (/ cons (float calls)))) ; cons-per-call
1123 *monitor-results*))))
1124 (display-monitoring-results threshold key ignore-no-calls)))))
1125
1126 (defun display-monitoring-results (&optional (threshold 0.01) (key :percent-time)
1127 (ignore-no-calls t))
1128 (let ((max-length 8) ; Function header size
1129 (max-cons-length 8)
1130 (total-time 0.0)
1131 (total-consed 0)
1132 (total-calls 0)
1133 (total-percent-time 0)
1134 (total-percent-cons 0))
1135 (sort-results key)
1136 (dolist (result *monitor-results*)
1137 (when (or (zerop threshold)
1138 (> (m-info-percent-time result) threshold))
1139 (setq max-length
1140 (max max-length
1141 (length (m-info-name result))))
1142 (setq max-cons-length
1143 (max max-cons-length
1144 (m-info-cons-per-call result)))))
1145 (incf max-length 2)
1146 (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10))))
1147 (format *trace-output*
1148 "~%~%~
1149 ~VT ~VA~
1150 ~% ~VT % % ~VA Total Total~
1151 ~%Function~VT Time Cons Calls Sec/Call ~VA Time Cons~
1152 ~%~V,,,'-A"
1153 max-length
1154 max-cons-length "Cons"
1155 max-length
1156 max-cons-length "Per"
1157 max-length
1158 max-cons-length "Call"
1159 (+ max-length 62 (max 0 (- max-cons-length 5))) "-")
1160 (dolist (result *monitor-results*)
1161 (when (or (zerop threshold)
1162 (> (m-info-percent-time result) threshold))
1163 (format *trace-output*
1164 "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D"
1165 (m-info-name result)
1166 max-length
1167 (* 100 (m-info-percent-time result))
1168 (* 100 (m-info-percent-cons result))
1169 (m-info-calls result)
1170 (m-info-time-per-call result)
1171 max-cons-length
1172 (m-info-cons-per-call result)
1173 (m-info-time result)
1174 (m-info-cons result))
1175 (incf total-time (m-info-time result))
1176 (incf total-consed (m-info-cons result))
1177 (incf total-calls (m-info-calls result))
1178 (incf total-percent-time (m-info-percent-time result))
1179 (incf total-percent-cons (m-info-percent-cons result))))
1180 (format *trace-output*
1181 "~%~V,,,'-A~
1182 ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~
1183 ~%Estimated monitoring overhead: ~5,2F seconds~
1184 ~%Estimated total monitoring overhead: ~5,2F seconds"
1185 (+ max-length 62 (max 0 (- max-cons-length 5))) "-"
1186 max-length
1187 (* 100 total-percent-time)
1188 (* 100 total-percent-cons)
1189 total-calls
1190 max-cons-length " "
1191 total-time total-consed
1192 (/ (* *monitor-time-overhead* total-calls)
1193 time-units-per-second)
1194 *estimated-total-overhead*)
1195 (when (and (not ignore-no-calls) *no-calls*)
1196 (setq *no-calls* (sort *no-calls* #'string<))
1197 (let ((num-no-calls (length *no-calls*)))
1198 (if (> num-no-calls 20)
1199 (format *trace-output*
1200 "~%~@(~r~) monitored functions were not called. ~
1201 ~%See the variable mon::*no-calls* for a list."
1202 num-no-calls)
1203 (format *trace-output*
1204 "~%The following monitored functions were not called:~
1205 ~%~{~<~%~:; ~A~>~}~%"
1206 *no-calls*))))
1207 (values)))
1208
1209 (defun sort-results (&optional (key :percent-time))
1210 (setq *monitor-results*
1211 (case key
1212 (:function (sort *monitor-results* #'string>
1213 :key #'m-info-name))
1214 ((:percent-time :time) (sort *monitor-results* #'>
1215 :key #'m-info-time))
1216 ((:percent-cons :cons) (sort *monitor-results* #'>
1217 :key #'m-info-cons))
1218 (:calls (sort *monitor-results* #'>
1219 :key #'m-info-calls))
1220 (:time-per-call (sort *monitor-results* #'>
1221 :key #'m-info-time-per-call))
1222 (:cons-per-call (sort *monitor-results* #'>
1223 :key #'m-info-cons-per-call)))))
1224
1225 ;;; *END OF FILE*
1226
1227

  ViewVC Help
Powered by ViewVC 1.1.5