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

Contents of /slime/metering.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide 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 heller 1.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 lgorrie 1.3 ;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/
25 heller 1.1 ;;;
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 lgorrie 1.3 ;;; 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 heller 1.5 ;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL.
64 heller 1.6 ;;; 07-Aug-12 heller Break lines at 80 columns
65 heller 1.1 ;;;
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 lgorrie 1.3 ;;; Warn people using the wrong Lisp
352 heller 1.1 ;;; ********************************
353    
354 lgorrie 1.3 #-(or clisp openmcl)
355     (warn "metering.lisp does not support your Lisp implementation!")
356 heller 1.1
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 lgorrie 1.3 #-(or clisp openmcl)
399     (eval-when (compile eval)
400     (warn
401     "You may want to supply implementation-specific get-time functions."))
402 heller 1.1
403 lgorrie 1.3 (defconstant time-units-per-second internal-time-units-per-second)
404 heller 1.1
405 heller 1.5 #+openmcl
406     (progn
407     (deftype time-type () 'unsigned-byte)
408     (deftype consing-type () 'unsigned-byte))
409    
410 lgorrie 1.3 (defmacro get-time ()
411     `(the time-type (get-internal-run-time)))
412 heller 1.1
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 lgorrie 1.3 ;;; conditionalize the definition of get-time above with #-:openmcl.
423     ;#+openmcl
424 heller 1.1 ;(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 lgorrie 1.3 #+clisp
434 heller 1.1 (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 lgorrie 1.3 #+openmcl
450 lgorrie 1.4 (defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
451 lgorrie 1.3
452     #-(or clisp openmcl)
453 heller 1.1 (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 lgorrie 1.3 #+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 heller 1.6 ,gc1 ,gc2 ,beg-cons1 ,beg-cons2)
504     (sys::%%time)
505 lgorrie 1.3 (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
506     (multiple-value-prog1 ,form
507     (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2
508 heller 1.6 ,gc1 ,gc2 ,end-cons1 ,end-cons2)
509     (sys::%%time)
510 lgorrie 1.3 (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 heller 1.1
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 lgorrie 1.3 #+openmcl
531 heller 1.1 (defun required-arguments (name)
532     (let* ((function (symbol-function name))
533 lgorrie 1.3 (args (ccl:arglist function))
534 heller 1.1 (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 lgorrie 1.3 #+clisp
546 heller 1.1 (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 lgorrie 1.3 #-(or clisp openmcl)
554 heller 1.1 (progn
555     (eval-when (compile eval)
556     (warn
557 heller 1.6 "You may want to add an implementation-specific ~
558     Required-Arguments function."))
559 heller 1.1 (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 lgorrie 1.3 (old-definition nil :type function)
674     (new-definition nil :type function)
675     (read-metering nil :type function)
676     (reset-metering nil :type function))
677 heller 1.1
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 lgorrie 1.3 `(&rest optional-args)))
786 heller 1.1 (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 lgorrie 1.3 `(apply old-definition
800     ,@required-args optional-args)
801 heller 1.1 `(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 heller 1.6 (defun display-monitoring-results (&optional (threshold 0.01)
1110     (key :percent-time)
1111     (ignore-no-calls t))
1112 heller 1.1 (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 heller 1.6 ~% ~VT % % ~VA ~
1135     Total Total~
1136     ~%Function~VT Time Cons Calls Sec/Call ~VA ~
1137     Time Cons~
1138 heller 1.1 ~%~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