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

Contents of /slime/metering.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5