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