├── metering.asd ├── package.lisp ├── README.md └── metering.lisp /metering.asd: -------------------------------------------------------------------------------- 1 | ;;;; metering.asd 2 | 3 | (asdf:defsystem #:metering 4 | :description "Modernized Metering System." 5 | :author "Paul M. Rodriguez " 6 | :license "MIT" 7 | :serial t 8 | :depends-on (#:osicat 9 | #:swank) 10 | :components ((:file "package") 11 | (:file "metering"))) 12 | 13 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:monitor 4 | (:use #:cl) 5 | (:nicknames #:metering) 6 | (:export #:*monitored-functions* 7 | #:monitor #:monitor-package #:unmonitor #:monitor-form 8 | #:with-monitoring 9 | #:reset-monitoring-info #:reset-all-monitoring 10 | #:monitored 11 | #:report-monitoring #:*report-format* 12 | #:display-monitoring-results 13 | #:monitoring-encapsulate #:monitoring-unencapsulate 14 | #:report 15 | #:reset)) 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This is a lightly modernized version of the classic Metering System. 2 | It is a fork of the version included with Slime, and it only works in 3 | Clozure Common Lisp. 4 | 5 | The motivation for the fork is that the timestamps used by the 6 | Metering System are too coarse to give meaningful results on modern 7 | systems. Instead, we call out to the OS for nanosecond-resolution 8 | timestamps, and use double-floats for internal arithmetic to preserve 9 | the precision thus gained. 10 | 11 | As with every version of the Metering System, extensive usage notes 12 | are provided by a very long comment in the 13 | [source code](metering.lisp). The only surprises are: 14 | 15 | - `monitor-all` has been renamed to `monitor-package`, because that’s 16 | what it does; 17 | - `monitored` has been renamed to `monitoredp`, because it’s a 18 | predicate; 19 | - there is a `reset` function for more conveniently resetting 20 | monitoring info. 21 | -------------------------------------------------------------------------------- /metering.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*- 2 | ;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz 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 | ;;; 25 | ;;; 26 | 27 | ;;; ******************************** 28 | ;;; Change Log ********************* 29 | ;;; ******************************** 30 | ;;; 31 | ;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages. 32 | ;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics 33 | ;;; with respect to nested calls. (Allows it to subtract 34 | ;;; total monitoring overhead for each function, not just 35 | ;;; the time spent monitoring the function itself.) 36 | ;;; 26-JUN-90 mk The table is now saved so that one may manipulate 37 | ;;; the data (sorting it, etc.) even after the original 38 | ;;; source of the data has been cleared. 39 | ;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2 40 | ;;; required-arguments functions for Lucid 3.0, 41 | ;;; Franz Allegro CL, and MACL 1.3.2. 42 | ;;; 25-JAN-91 mk Now uses fdefinition if available. 43 | ;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl. 44 | ;;; Much better solution for the fact that both call 45 | ;;; themselves :allegro. 46 | ;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded 47 | ;;; uncompiled. 48 | ;;; 5-JUL-91 mk When many unmonitored functions, print out number 49 | ;;; instead of whole list. 50 | ;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring 51 | ;;; doesn't work in MCL, but fixed so that timing 52 | ;;; statistics do. 53 | ;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with 54 | ;;; (and :ccl (not :lispworks)). 55 | ;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0. 56 | ;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1, 57 | ;;; Lucid 4.0, ibcl 58 | ;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible. 59 | ;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL. 60 | ;;; Purely to cut down on stale code (e.g. #+cltl2) in this 61 | ;;; version that is bundled with SLIME. 62 | ;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL. 63 | ;;; 07-Aug-12 heller Break lines at 80 columns 64 | ;;; 07-Jun-15 pmr Split off from Slime. 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 | ;;; (monitor:with-monitoring (names*) () 148 | ;;; your-forms*) 149 | ;;; or 150 | ;;; (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 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-PACKAGE &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 | ;;; MONITOREDP 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 | ;;; - AS specifies how to print the report: as text (:text) or as 309 | ;;; html (:html). 310 | ;;; 311 | ;;; REPORT &key (names :all) [Function] 312 | ;;; (nested :exclusive) 313 | ;;; (threshold 0.01) 314 | ;;; (sort-key :percent-time) 315 | ;;; (ignore-no-calls nil) 316 | ;;; (as *report-format*) 317 | ;;; 318 | ;;; Same as REPORT-MONITORING but we use a nicer keyword interface. 319 | ;;; 320 | ;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function] 321 | ;;; (key :percent-time) 322 | ;;; Prints a table showing for each named function: 323 | ;;; - the total CPU time used in that function for all calls 324 | ;;; - the total number of bytes consed in that function for all calls 325 | ;;; - the total number of calls 326 | ;;; - the average amount of CPU time per call 327 | ;;; - the average amount of consing per call 328 | ;;; - the percent of total execution time spent executing that function 329 | ;;; - the percent of total consing spent consing in that function 330 | ;;; Summary totals of the CPU time, consing, and calls columns are printed. 331 | ;;; An estimate of the monitoring overhead is also printed. May be run 332 | ;;; even after unmonitoring all the functions, to play with the data. 333 | ;;; 334 | ;;; SAMPLE TABLE: 335 | #| 336 | Cons 337 | % % Per Total Total 338 | Function Time Cons Calls Sec/Call Call Time Cons 339 | ---------------------------------------------------------------------- 340 | FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0 341 | GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0 342 | GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0 343 | FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0 344 | ---------------------------------------------------------------------- 345 | TOTAL: 1173 0.828950 0 346 | Estimated total monitoring overhead: 0.88 seconds 347 | |# 348 | 349 | ;;; **************************************************************** 350 | ;;; METERING ******************************************************* 351 | ;;; **************************************************************** 352 | 353 | ;;; ******************************** 354 | ;;; Warn people using the wrong Lisp 355 | ;;; ******************************** 356 | 357 | #-(or clisp openmcl) 358 | (warn "metering.lisp does not support your Lisp implementation!") 359 | 360 | ;;; ******************************** 361 | ;;; Packages *********************** 362 | ;;; ******************************** 363 | 364 | (in-package #:monitor) 365 | 366 | ;;; ******************************** 367 | ;;; Version ************************ 368 | ;;; ******************************** 369 | 370 | (defparameter *metering-version* "v2.1 25-JAN-94" 371 | "Current version number/date for Metering.") 372 | 373 | 374 | ;;; **************************************************************** 375 | ;;; Implementation Dependent Definitions *************************** 376 | ;;; **************************************************************** 377 | 378 | ;;; ******************************** 379 | ;;; Timing Functions *************** 380 | ;;; ******************************** 381 | ;;; The get-time function is called to find the total number of ticks since 382 | ;;; the beginning of time. time-units-per-second allows us to convert units 383 | ;;; to seconds. 384 | 385 | (defconstant time-units-per-second 386 | (* 1 (expt 10 9)) 387 | "Nanoseconds per second.") 388 | 389 | (defun get-monotonic-time () 390 | "Get time with nanosecond resolution." 391 | (declare (optimize (speed 3) (safety 0) (debug 0))) 392 | (multiple-value-bind (seconds nanoseconds) 393 | (nix:clock-gettime nix:clock-process-cputime-id) 394 | (declare (type (integer 0 #.(1- (* 1 (expt 10 9)))) nanoseconds)) 395 | (+ (* seconds time-units-per-second) nanoseconds))) 396 | 397 | (deftype time-type () 'unsigned-byte) 398 | (deftype consing-type () 'unsigned-byte) 399 | 400 | (defmacro get-time () 401 | `(the time-type (get-monotonic-time))) 402 | 403 | ;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of 404 | ;;; milliseconds spent during GC. We could subtract this from 405 | ;;; the value returned by get-internal-run-time to eliminate 406 | ;;; the effect of GC on the timing values, but we prefer to let 407 | ;;; the user run without GC on. If the application is so big that 408 | ;;; it requires GC to complete, then the GC times are part of the 409 | ;;; cost of doing business, and will average out in the long run. 410 | ;;; If it seems really important to a user that GC times not be 411 | ;;; counted, then uncomment the following three lines and read-time 412 | ;;; conditionalize the definition of get-time above with #-:openmcl. 413 | ;#+openmcl 414 | ;(defmacro get-time () 415 | ; `(the time-type (- (get-internal-run-time) (ccl:gctime)))) 416 | 417 | ;;; ******************************** 418 | ;;; Consing Functions ************** 419 | ;;; ******************************** 420 | ;;; The get-cons macro is called to find the total number of bytes 421 | ;;; consed since the beginning of time. 422 | 423 | #+clisp 424 | (defun get-cons () 425 | (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount) 426 | (sys::%%time) 427 | (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount)) 428 | (dpb space1 (byte 24 24) space2))) 429 | 430 | ;;; Macintosh Common Lisp 2.0 431 | ;;; Note that this includes bytes that were allocated during GC. 432 | ;;; We could subtract this out by advising GC like we did under 433 | ;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't 434 | ;;; run without GC, then the bytes consed during GC are a cost of 435 | ;;; running their program. Metering the code a few times will 436 | ;;; avoid the consing values being too lopsided. If a user really really 437 | ;;; wants to subtract out the consing during GC, replace the following 438 | ;;; two lines with the commented out code. 439 | #+openmcl 440 | (defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated))) 441 | 442 | #-(or clisp openmcl) 443 | (progn 444 | (eval-when (compile eval) 445 | (warn "No consing will be reported unless a get-cons function is ~ 446 | defined.")) 447 | 448 | (defmacro get-cons () '(the consing-type 0))) 449 | 450 | ;; actually, neither `get-cons' nor `get-time' are used as is, 451 | ;; but only in the following macro `with-time/cons' 452 | #-:clisp 453 | (defmacro with-time/cons ((delta-time delta-cons) form &body post-process) 454 | (let ((start-cons (gensym "START-CONS-")) 455 | (start-time (gensym "START-TIME-"))) 456 | `(let ((,start-time (get-time)) (,start-cons (get-cons))) 457 | (declare (type time-type ,start-time) 458 | (type consing-type ,start-cons)) 459 | (multiple-value-prog1 ,form 460 | (let ((,delta-time (- (get-time) ,start-time)) 461 | (,delta-cons (- (get-cons) ,start-cons))) 462 | ,@post-process))))) 463 | 464 | #+clisp 465 | (progn 466 | (defmacro delta4 (nv1 nv2 ov1 ov2 by) 467 | `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2)) 468 | 469 | (let ((del (find-symbol "DELTA4" "SYS"))) 470 | (when del (setf (fdefinition 'delta4) (fdefinition del)))) 471 | 472 | (if (< internal-time-units-per-second 1000000) 473 | ;; TIME_1: AMIGA, OS/2, UNIX_TIMES 474 | (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) 475 | `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16)) 476 | ;; TIME_2: other UNIX, WIN32 477 | (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) 478 | `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second) 479 | (- ,new-time2 ,old-time2)))) 480 | 481 | (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2) 482 | `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24)) 483 | 484 | ;; avoid consing: when the application conses a lot, 485 | ;; get-cons may return a bignum, so we really should not use it. 486 | (defmacro with-time/cons ((delta-time delta-cons) form &body post-process) 487 | (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-")) 488 | (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-")) 489 | (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-")) 490 | (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-")) 491 | (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym))) 492 | `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2 493 | ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) 494 | (sys::%%time) 495 | (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) 496 | (multiple-value-prog1 ,form 497 | (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2 498 | ,gc1 ,gc2 ,end-cons1 ,end-cons2) 499 | (sys::%%time) 500 | (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) 501 | (let ((,delta-time (delta4-time ,end-time1 ,end-time2 502 | ,beg-time1 ,beg-time2)) 503 | (,delta-cons (delta4-cons ,end-cons1 ,end-cons2 504 | ,beg-cons1 ,beg-cons2))) 505 | ,@post-process))))))) 506 | 507 | ;;; ******************************** 508 | ;;; Required Arguments ************* 509 | ;;; ******************************** 510 | ;;; 511 | ;;; Required (Fixed) vs Optional Args 512 | ;;; 513 | ;;; To avoid unnecessary consing in the "encapsulation" code, we find out the 514 | ;;; number of required arguments, and use &rest to capture only non-required 515 | ;;; arguments. The function Required-Arguments returns two values: the first 516 | ;;; is the number of required arguments, and the second is T iff there are any 517 | ;;; non-required arguments (e.g. &optional, &rest, &key). 518 | 519 | (defun required-arguments (name) 520 | (let ((args (swank-backend:arglist name))) 521 | (if (eql args :not-available) 522 | (values 0 t) 523 | (let ((pos (position-if #'(lambda (x) 524 | (and (symbolp x) 525 | (let ((name (symbol-name x))) 526 | (and (>= (length name) 1) 527 | (char= (schar name 0) 528 | #\&))))) 529 | args))) 530 | (if pos 531 | (values pos t) 532 | (values (length args) nil)))))) 533 | 534 | #| 535 | ;;;Examples 536 | (defun square (x) (* x x)) 537 | (defun square2 (x &optional y) (* x x y)) 538 | (defun test (x y &optional (z 3)) 3) 539 | (defun test2 (x y &optional (z 3) &rest fred) 3) 540 | 541 | (required-arguments 'square) => 1 nil 542 | (required-arguments 'square2) => 1 t 543 | (required-arguments 'test) => 2 t 544 | (required-arguments 'test2) => 2 t 545 | |# 546 | 547 | 548 | ;;; **************************************************************** 549 | ;;; Main METERING Code ********************************************* 550 | ;;; **************************************************************** 551 | 552 | ;;; ******************************** 553 | ;;; Global Variables *************** 554 | ;;; ******************************** 555 | (defvar *MONITOR-TIME-OVERHEAD* nil 556 | "The amount of time an empty monitored function costs.") 557 | (defvar *MONITOR-CONS-OVERHEAD* nil 558 | "The amount of cons an empty monitored function costs.") 559 | 560 | (defvar *TOTAL-TIME* 0 561 | "Total amount of time monitored so far.") 562 | (defvar *TOTAL-CONS* 0 563 | "Total amount of consing monitored so far.") 564 | (defvar *TOTAL-CALLS* 0 565 | "Total number of calls monitored so far.") 566 | (declaim (type time-type *total-time*)) 567 | (declaim (type consing-type *total-cons*)) 568 | (declaim (fixnum *total-calls*)) 569 | 570 | ;;; ******************************** 571 | ;;; Accessor Functions ************* 572 | ;;; ******************************** 573 | ;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables 574 | ;;; containing closures. 575 | (defmacro PLACE-FUNCTION (function-place) 576 | "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE 577 | if it isn't a symbol, to allow monitoring of closures located in 578 | variables/arrays/structures." 579 | ;; Note that (fboundp 'fdefinition) returns T even if fdefinition 580 | ;; is a macro, which is what we want. 581 | (if (fboundp 'fdefinition) 582 | `(if (fboundp ,function-place) 583 | (fdefinition ,function-place) 584 | (eval ,function-place)) 585 | `(if (symbolp ,function-place) 586 | (symbol-function ,function-place) 587 | (eval ,function-place)))) 588 | 589 | (defsetf PLACE-FUNCTION (function-place) (function) 590 | "Set the function in FUNCTION-PLACE to FUNCTION." 591 | (if (fboundp 'fdefinition) 592 | ;; If we're conforming to CLtL2, use fdefinition here. 593 | `(if (fboundp ,function-place) 594 | (setf (fdefinition ,function-place) ,function) 595 | (eval '(setf ,function-place ',function))) 596 | `(if (symbolp ,function-place) 597 | (setf (symbol-function ,function-place) ,function) 598 | (eval '(setf ,function-place ',function))))) 599 | 600 | #| 601 | ;;; before using fdefinition 602 | (defun PLACE-FUNCTION (function-place) 603 | "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE 604 | if it isn't a symbol, to allow monitoring of closures located in 605 | variables/arrays/structures." 606 | (if (symbolp function-place) 607 | (symbol-function function-place) 608 | (eval function-place))) 609 | 610 | (defsetf PLACE-FUNCTION (function-place) (function) 611 | "Set the function in FUNCTION-PLACE to FUNCTION." 612 | `(if (symbolp ,function-place) 613 | (setf (symbol-function ,function-place) ,function) 614 | (eval '(setf ,function-place ',function)))) 615 | |# 616 | 617 | (defun PLACE-FBOUNDP (function-place) 618 | "Test to see if FUNCTION-PLACE is a function." 619 | ;; probably should be 620 | #|(or (and (symbolp function-place)(fboundp function-place)) 621 | (functionp (place-function function-place)))|# 622 | (if (symbolp function-place) 623 | (fboundp function-place) 624 | (functionp (place-function function-place)))) 625 | 626 | (defun PLACE-MACROP (function-place) 627 | "Test to see if FUNCTION-PLACE is a macro." 628 | (when (symbolp function-place) 629 | (macro-function function-place))) 630 | 631 | ;;; ******************************** 632 | ;;; Measurement Tables ************* 633 | ;;; ******************************** 634 | (defvar *monitored-functions* nil 635 | "List of monitored symbols.") 636 | 637 | ;;; We associate a METERING-FUNCTIONS structure with each monitored function 638 | ;;; name or other closure. This holds the functions that we call to manipulate 639 | ;;; the closure which implements the encapsulation. 640 | ;;; 641 | (defclass metering-functions () 642 | ((name 643 | :initarg :name 644 | :initform nil 645 | :accessor metering-functions-name) 646 | (old-definition 647 | :initarg :old-definition 648 | :initform nil 649 | :type function 650 | :accessor metering-functions-old-definition) 651 | (new-definition 652 | :initarg :new-definition 653 | :initform nil 654 | :type function 655 | :accessor metering-functions-new-definition) 656 | (read-metering 657 | :initarg :read-metering 658 | :initform nil 659 | :type function 660 | :accessor metering-functions-read-metering) 661 | (reset-metering 662 | :initarg :reset-metering 663 | :initform nil 664 | :type function 665 | :accessor metering-functions-reset-metering))) 666 | 667 | (defun make-metering-functions (&rest args) 668 | (apply #'make-instance 669 | 'metering-functions 670 | args)) 671 | 672 | ;;; In general using hash tables in time-critical programs is a bad idea, 673 | ;;; because when one has to grow the table and rehash everything, the 674 | ;;; timing becomes grossly inaccurate. In this case it is not an issue 675 | ;;; because all inserting of entries in the hash table occurs before the 676 | ;;; timing commences. The only circumstance in which this could be a 677 | ;;; problem is if the lisp rehashes on the next reference to the table, 678 | ;;; instead of when the entry which forces a rehash was inserted. 679 | ;;; 680 | ;;; Note that a similar kind of problem can occur with GC, which is why 681 | ;;; one should turn off GC when monitoring code. 682 | ;;; 683 | (defvar *monitor* (make-hash-table :test #'equal) 684 | "Hash table in which METERING-FUNCTIONS structures are stored.") 685 | (defun get-monitor-info (name) 686 | (gethash name *monitor*)) 687 | (defsetf get-monitor-info (name) (info) 688 | `(setf (gethash ,name *monitor*) ,info)) 689 | 690 | (defun MONITOREDP (function-place) 691 | "Test to see if a FUNCTION-PLACE is monitored." 692 | (and (place-fboundp function-place) ; this line necessary? 693 | (get-monitor-info function-place))) 694 | 695 | (defun reset-monitoring-info (name) 696 | "Reset the monitoring info for the specified function." 697 | (let ((finfo (get-monitor-info name))) 698 | (when finfo 699 | (funcall (metering-functions-reset-metering finfo))))) 700 | (defun reset-all-monitoring () 701 | "Reset monitoring info for all functions." 702 | (setq *total-time* 0 703 | *total-cons* 0 704 | *total-calls* 0) 705 | (dolist (symbol *monitored-functions*) 706 | (when (monitored symbol) 707 | (reset-monitoring-info symbol)))) 708 | (defun reset (&rest names) 709 | (if names 710 | (mapc #'reset-monitoring-info names) 711 | (reset-all-monitoring))) 712 | 713 | (defun monitor-info-values (name &optional (nested :exclusive) warn) 714 | "Returns monitoring information values for the named function, 715 | adjusted for overhead." 716 | (let ((finfo (get-monitor-info name))) 717 | (if finfo 718 | (multiple-value-bind (inclusive-time inclusive-cons 719 | exclusive-time exclusive-cons 720 | calls nested-calls) 721 | (funcall (metering-functions-read-metering finfo)) 722 | (unless (or (null warn) 723 | (eq (place-function name) 724 | (metering-functions-new-definition finfo))) 725 | (warn "Funtion ~S has been redefined, so times may be inaccurate.~@ 726 | MONITOR it again to record calls to the new definition." 727 | name)) 728 | (case nested 729 | (:exclusive (values calls 730 | nested-calls 731 | (- exclusive-time 732 | (* calls *monitor-time-overhead*)) 733 | (- exclusive-cons 734 | (* calls *monitor-cons-overhead*)))) 735 | ;; In :inclusive mode, subtract overhead for all the 736 | ;; called functions as well. Nested-calls includes the 737 | ;; calls of the function as well. [Necessary 'cause of 738 | ;; functions which call themselves recursively.] 739 | (:inclusive (values calls 740 | nested-calls 741 | (- inclusive-time 742 | (* nested-calls ;(+ calls) 743 | *monitor-time-overhead*)) 744 | (- inclusive-cons 745 | (* nested-calls ;(+ calls) 746 | *monitor-cons-overhead*)))))) 747 | (values 0 0 0 0)))) 748 | 749 | ;;; ******************************** 750 | ;;; Encapsulate ******************** 751 | ;;; ******************************** 752 | (eval-when (compile load eval) 753 | ;; Returns a lambda expression for a function that, when called with the 754 | ;; function name, will set up that function for metering. 755 | ;; 756 | ;; A function is monitored by replacing its definition with a closure 757 | ;; created by the following function. The closure records the monitoring 758 | ;; data, and updates the data with each call of the function. 759 | ;; 760 | ;; Other closures are used to read and reset the data. 761 | (defun make-monitoring-encapsulation (min-args optionals-p) 762 | (let (required-args) 763 | (dotimes (i min-args) (push (gensym) required-args)) 764 | `(lambda (name) 765 | (let ((inclusive-time 0) 766 | (inclusive-cons 0) 767 | (exclusive-time 0) 768 | (exclusive-cons 0) 769 | (calls 0) 770 | (nested-calls 0) 771 | (old-definition (place-function name))) 772 | (declare (type time-type inclusive-time) 773 | (type time-type exclusive-time) 774 | (type consing-type inclusive-cons) 775 | (type consing-type exclusive-cons) 776 | (fixnum calls) 777 | (fixnum nested-calls)) 778 | (pushnew name *monitored-functions*) 779 | 780 | (setf (place-function name) 781 | #'(lambda (,@required-args 782 | ,@(when optionals-p 783 | `(&rest optional-args))) 784 | (let ((prev-total-time *total-time*) 785 | (prev-total-cons *total-cons*) 786 | (prev-total-calls *total-calls*) 787 | ;; (old-time inclusive-time) 788 | ;; (old-cons inclusive-cons) 789 | ;; (old-nested-calls nested-calls) 790 | ) 791 | (declare (type time-type prev-total-time) 792 | (type consing-type prev-total-cons) 793 | (fixnum prev-total-calls)) 794 | (with-time/cons (delta-time delta-cons) 795 | ;; form 796 | ,(if optionals-p 797 | `(apply old-definition 798 | ,@required-args optional-args) 799 | `(funcall old-definition ,@required-args)) 800 | ;; post-processing: 801 | ;; Calls 802 | (incf calls) 803 | (incf *total-calls*) 804 | ;; nested-calls includes this call 805 | (incf nested-calls (the fixnum 806 | (- *total-calls* 807 | prev-total-calls))) 808 | ;; (setf nested-calls (+ old-nested-calls 809 | ;; (- *total-calls* 810 | ;; prev-total-calls))) 811 | ;; Time 812 | ;; Problem with inclusive time is that it 813 | ;; currently doesn't add values from recursive 814 | ;; calls to the same function. Change the 815 | ;; setf to an incf to fix this? 816 | (incf inclusive-time (the time-type delta-time)) 817 | ;; (setf inclusive-time (+ delta-time old-time)) 818 | (incf exclusive-time (the time-type 819 | (+ delta-time 820 | (- prev-total-time 821 | *total-time*)))) 822 | (setf *total-time* (the time-type 823 | (+ delta-time 824 | prev-total-time))) 825 | ;; Consing 826 | (incf inclusive-cons (the consing-type delta-cons)) 827 | ;; (setf inclusive-cons (+ delta-cons old-cons)) 828 | (incf exclusive-cons (the consing-type 829 | (+ delta-cons 830 | (- prev-total-cons 831 | *total-cons*)))) 832 | (setf *total-cons* 833 | (the consing-type 834 | (+ delta-cons prev-total-cons))))))) 835 | (setf (get-monitor-info name) 836 | (make-metering-functions 837 | :name name 838 | :old-definition old-definition 839 | :new-definition (place-function name) 840 | :read-metering #'(lambda () 841 | (values inclusive-time 842 | inclusive-cons 843 | exclusive-time 844 | exclusive-cons 845 | calls 846 | nested-calls)) 847 | :reset-metering #'(lambda () 848 | (setq inclusive-time 0 849 | inclusive-cons 0 850 | exclusive-time 0 851 | exclusive-cons 0 852 | calls 0 853 | nested-calls 0) 854 | t))))))) 855 | );; End of EVAL-WHEN 856 | 857 | ;;; For efficiency reasons, we precompute the encapsulation functions 858 | ;;; for a variety of combinations of argument structures 859 | ;;; (min-args . optional-p). These are stored in the following hash table 860 | ;;; along with any new ones we encounter. Since we're now precomputing 861 | ;;; closure functions for common argument signatures, this eliminates 862 | ;;; the former need to call COMPILE for each monitored function. 863 | (eval-when (compile eval) 864 | (defconstant precomputed-encapsulations 8)) 865 | 866 | (defvar *existing-encapsulations* (make-hash-table :test #'equal)) 867 | (defun find-encapsulation (min-args optionals-p) 868 | (or (gethash (cons min-args optionals-p) *existing-encapsulations*) 869 | (setf (gethash (cons min-args optionals-p) *existing-encapsulations*) 870 | (compile nil 871 | (make-monitoring-encapsulation min-args optionals-p))))) 872 | 873 | (macrolet ((frob () 874 | (let ((res ())) 875 | (dotimes (i precomputed-encapsulations) 876 | (push `(setf (gethash '(,i . nil) *existing-encapsulations*) 877 | #',(make-monitoring-encapsulation i nil)) 878 | res) 879 | (push `(setf (gethash '(,i . t) *existing-encapsulations*) 880 | #',(make-monitoring-encapsulation i t)) 881 | res)) 882 | `(progn ,@res)))) 883 | (frob)) 884 | 885 | (defun monitoring-encapsulate (name &optional warn) 886 | "Monitor the function Name. If already monitored, unmonitor first." 887 | ;; Saves the current definition of name and inserts a new function which 888 | ;; returns the result of evaluating body. 889 | (cond ((not (place-fboundp name)) ; not a function 890 | (when warn 891 | (warn "Ignoring undefined function ~S." name))) 892 | ((place-macrop name) ; a macro 893 | (when warn 894 | (warn "Ignoring macro ~S." name))) 895 | (t ; tis a function 896 | (when (get-monitor-info name) ; monitored 897 | (when warn 898 | (warn "~S already monitored, so unmonitoring it first." name)) 899 | (monitoring-unencapsulate name)) 900 | (multiple-value-bind (min-args optionals-p) 901 | (required-arguments name) 902 | (funcall (find-encapsulation min-args optionals-p) name))))) 903 | 904 | (defun monitoring-unencapsulate (name &optional warn) 905 | "Removes monitoring encapsulation code from around Name." 906 | (let ((finfo (get-monitor-info name))) 907 | (when finfo ; monitored 908 | ;; TODO Is this necessary? 909 | (when (symbolp name) 910 | (remprop name 'metering-functions)) 911 | (setq *monitored-functions* 912 | (remove name *monitored-functions* :test #'equal)) 913 | (if (eq (place-function name) 914 | (metering-functions-new-definition finfo)) 915 | (setf (place-function name) 916 | (metering-functions-old-definition finfo)) 917 | (when warn 918 | (warn "Preserving current definition of redefined function ~S." 919 | name)))))) 920 | 921 | ;;; ******************************** 922 | ;;; Main Monitoring Functions ****** 923 | ;;; ******************************** 924 | (defmacro MONITOR (&rest names) 925 | "Monitor the named functions. As in TRACE, the names are not evaluated. 926 | If a function is already monitored, then unmonitor and remonitor (useful 927 | to notice function redefinition). If a name is undefined, give a warning 928 | and ignore it. See also unmonitor, report-monitoring, 929 | display-monitoring-results and reset-time." 930 | `(progn 931 | ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names) 932 | *monitored-functions*)) 933 | 934 | (defmacro UNMONITOR (&rest names) 935 | "Remove the monitoring on the named functions. 936 | Names defaults to the list of all currently monitored functions." 937 | `(dolist (name ,(if names `',names '*monitored-functions*) (values)) 938 | (monitoring-unencapsulate name))) 939 | 940 | (defun MONITOR-PACKAGE (&optional (package *package*)) 941 | "Monitor all functions in the specified package." 942 | (let ((package (if (packagep package) 943 | package 944 | (find-package package)))) 945 | (do-symbols (symbol package) 946 | (when (eq (symbol-package symbol) package) 947 | (monitoring-encapsulate symbol))))) 948 | 949 | (defmacro MONITOR-FORM (form 950 | &optional (nested :exclusive) (threshold 0.01) 951 | (key :percent-time)) 952 | "Monitor the execution of all functions in the current package 953 | during the execution of FORM. All functions that are executed above 954 | THRESHOLD % will be reported." 955 | `(unwind-protect 956 | (progn 957 | (monitor-package) 958 | (reset-all-monitoring) 959 | (prog1 960 | (time ,form) 961 | (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls))) 962 | (unmonitor))) 963 | 964 | (defmacro WITH-MONITORING ((&rest functions) 965 | (&optional (nested :exclusive) 966 | (threshold 0.01) 967 | (key :percent-time)) 968 | &body body) 969 | "Monitor the specified functions during the execution of the body." 970 | `(unwind-protect 971 | (progn 972 | (dolist (fun ',functions) 973 | (monitoring-encapsulate fun)) 974 | (reset-all-monitoring) 975 | ,@body 976 | (report-monitoring :all ,nested ,threshold ,key)) 977 | (unmonitor))) 978 | 979 | ;;; ******************************** 980 | ;;; Overhead Calculations ********** 981 | ;;; ******************************** 982 | (defparameter *overhead-iterations* 5000 983 | "Number of iterations over which the timing overhead is averaged.") 984 | 985 | ;;; Perhaps this should return something to frustrate clever compilers. 986 | (declaim (notinline stub-function)) 987 | (defun STUB-FUNCTION (x) 988 | (declare (ignore x)) 989 | nil) 990 | 991 | (defun SET-MONITOR-OVERHEAD () 992 | "Determines the average overhead of monitoring by monitoring the execution 993 | of an empty function many times." 994 | (setq *monitor-time-overhead* 0 995 | *monitor-cons-overhead* 0) 996 | (stub-function nil) 997 | (monitor stub-function) 998 | (reset-all-monitoring) 999 | (let ((overhead-function (symbol-function 'stub-function))) 1000 | (dotimes (x *overhead-iterations*) 1001 | (funcall overhead-function overhead-function))) 1002 | (let ((fiter (float *overhead-iterations* 0d0))) 1003 | (multiple-value-bind (calls nested-calls time cons) 1004 | (monitor-info-values 'stub-function) 1005 | (declare (ignore calls nested-calls)) 1006 | (setq *monitor-time-overhead* (/ time fiter) 1007 | *monitor-cons-overhead* (/ cons fiter)))) 1008 | (unmonitor stub-function)) 1009 | (set-monitor-overhead) 1010 | 1011 | ;;; ******************************** 1012 | ;;; Report Data ******************** 1013 | ;;; ******************************** 1014 | (defvar *monitor-results* nil 1015 | "A table of monitoring statistics is stored here.") 1016 | (defvar *no-calls* nil 1017 | "A list of monitored functions which weren't called.") 1018 | (defvar *estimated-total-overhead* 0) 1019 | 1020 | (defvar *report-format* :text 1021 | "How to print the report. 1022 | Can be one of :text (for text) or :html (for HTML).") 1023 | (declaim (type (member :html :text) *report-format*)) 1024 | 1025 | (defclass monitoring-info () 1026 | ((name 1027 | :initarg :name 1028 | :accessor m-info-name) 1029 | (calls 1030 | :initarg :calls 1031 | :accessor m-info-calls) 1032 | (time 1033 | :initarg :time 1034 | :accessor m-info-time) 1035 | (cons 1036 | :initarg :cons 1037 | :accessor m-info-cons) 1038 | (percent-time 1039 | :initarg :percent-time 1040 | :accessor m-info-percent-time) 1041 | (percent-cons 1042 | :initarg :percent-cons 1043 | :accessor m-info-percent-cons) 1044 | (time-per-call 1045 | :initarg :time-per-call 1046 | :accessor m-info-time-per-call) 1047 | (cons-per-call 1048 | :initarg :cons-per-call 1049 | :accessor m-info-cons-per-call))) 1050 | 1051 | (defun make-monitoring-info (name calls time cons 1052 | percent-time percent-cons 1053 | time-per-call cons-per-call) 1054 | (make-instance 'monitoring-info 1055 | :name name 1056 | :calls calls 1057 | :time time 1058 | :cons cons 1059 | :percent-time percent-time 1060 | :percent-cons percent-cons 1061 | :time-per-call time-per-call 1062 | :cons-per-call cons-per-call)) 1063 | 1064 | (defun REPORT (&key (names :all) 1065 | (nested :exclusive) 1066 | (threshold 0.01) 1067 | (sort-key :percent-time) 1068 | (ignore-no-calls nil) 1069 | ((:as *report-format*) *report-format*)) 1070 | "Same as REPORT-MONITORING but with a nicer keyword interface" 1071 | (declare (type (member :function :percent-time :time :percent-cons 1072 | :cons :calls :time-per-call :cons-per-call) 1073 | sort-key) 1074 | (type (member :inclusive :exclusive) nested)) 1075 | (report-monitoring names nested threshold sort-key ignore-no-calls)) 1076 | 1077 | (defun REPORT-MONITORING (&optional names 1078 | (nested :exclusive) 1079 | (threshold 0.01) 1080 | (key :percent-time) 1081 | ignore-no-calls 1082 | (*report-format* *report-format*)) 1083 | "Report the current monitoring state. 1084 | The percentage of the total time spent executing unmonitored code 1085 | in each function (:exclusive mode), or total time (:inclusive mode) 1086 | will be printed together with the number of calls and 1087 | the unmonitored time per call. Functions that have been executed 1088 | below THRESHOLD % of the time will not be reported. To report on all 1089 | functions set NAMES to be either NIL or :ALL." 1090 | (when (or (null names) (eq names :all)) (setq names *monitored-functions*)) 1091 | 1092 | (let ((total-time 0) 1093 | (total-cons 0) 1094 | (total-calls 0)) 1095 | ;; Compute overall time and consing. 1096 | (dolist (name names) 1097 | (multiple-value-bind (calls nested-calls time cons) 1098 | (monitor-info-values name nested :warn) 1099 | (declare (ignore nested-calls)) 1100 | (incf total-calls calls) 1101 | (incf total-time time) 1102 | (incf total-cons cons))) 1103 | ;; Total overhead. 1104 | (setq *estimated-total-overhead* 1105 | (/ (* *monitor-time-overhead* total-calls) 1106 | time-units-per-second)) 1107 | ;; Assemble data for only the specified names (all monitored functions) 1108 | (if (zerop total-time) 1109 | (format *trace-output* "Not enough execution time to monitor.") 1110 | (progn 1111 | (setq *monitor-results* nil *no-calls* nil) 1112 | (dolist (name names) 1113 | (multiple-value-bind (calls nested-calls time cons) 1114 | (monitor-info-values name nested) 1115 | (declare (ignore nested-calls)) 1116 | (when (minusp time) (setq time 0.0)) 1117 | (when (minusp cons) (setq cons 0.0)) 1118 | (if (zerop calls) 1119 | (push (if (symbolp name) 1120 | (symbol-name name) 1121 | (format nil "~S" name)) 1122 | *no-calls*) 1123 | (push (make-monitoring-info 1124 | (format nil "~S" name) ; name 1125 | calls ; calls 1126 | (/ time (float time-units-per-second 0d0)) ; time in secs 1127 | (round cons) ; consing 1128 | (/ time (float total-time 0d0)) ; percent-time 1129 | (if (zerop total-cons) 0 1130 | (/ cons (float total-cons 0d0))) ; percent-cons 1131 | (/ (/ time (float calls 0d0)) ; time-per-call 1132 | time-units-per-second) ; sec/call 1133 | (round (/ cons (float calls 0d0)))) ; cons-per-call 1134 | *monitor-results*)))) 1135 | (display-monitoring-results threshold key ignore-no-calls))))) 1136 | 1137 | (defmethod results-table-header ((fmt (eql :text)) &key max-length max-cons-length) 1138 | (format *trace-output* 1139 | "~%~%~ 1140 | ~VT ~VA~ 1141 | ~% ~VT % % ~VA ~ 1142 | Total Total~ 1143 | ~%Function~VT Time Cons Calls Sec/Call ~VA ~ 1144 | Time Cons~ 1145 | ~%~V,,,'-A" 1146 | max-length 1147 | max-cons-length "Cons" 1148 | max-length 1149 | max-cons-length "Per" 1150 | max-length 1151 | max-cons-length "Call" 1152 | (+ max-length 62 (max 0 (- max-cons-length 5))) "-")) 1153 | 1154 | (defmethod results-table-header ((fmt (eql :html)) &key max-length max-cons-length) 1155 | (declare (ignore max-length max-cons-length)) 1156 | (format *trace-output* 1157 | "~ 1158 | 1159 | 1160 | 1161 | 1162 | 1163 | 1164 | 1165 | 1166 | 1167 | 1168 | 1169 | 1170 | 1171 | ~%")) 1172 | 1173 | (defmethod results-table-row ((fmt (eql :text)) result &key max-length max-cons-length) 1174 | (format *trace-output* 1175 | "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D" 1176 | (m-info-name result) 1177 | max-length 1178 | (* 100 (m-info-percent-time result)) 1179 | (* 100 (m-info-percent-cons result)) 1180 | (m-info-calls result) 1181 | (m-info-time-per-call result) 1182 | max-cons-length 1183 | (m-info-cons-per-call result) 1184 | (m-info-time result) 1185 | (m-info-cons result))) 1186 | 1187 | (defmethod results-table-row ((fmt (eql :html)) result &key max-length max-cons-length) 1188 | (declare (ignore max-length)) 1189 | (format *trace-output* 1190 | "~&~ 1191 | 1192 | 1193 | 1194 | 1195 | 1196 | 1197 | 1198 | 1199 | 1200 | ~%" 1201 | (m-info-name result) 1202 | (* 100 (m-info-percent-time result)) 1203 | (* 100 (m-info-percent-cons result)) 1204 | (m-info-calls result) 1205 | (m-info-time-per-call result) 1206 | max-cons-length 1207 | (m-info-cons-per-call result) 1208 | (m-info-time result) 1209 | (m-info-cons result))) 1210 | 1211 | (defmethod results-table-footer ((fmt (eql :text)) 1212 | &key max-length max-cons-length 1213 | total-percent-time total-percent-cons 1214 | total-calls total-time total-consed) 1215 | (format *trace-output* 1216 | "~%~V,,,'-A~ 1217 | ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~ 1218 | ~%Estimated monitoring overhead: ~5,2F seconds~ 1219 | ~%Estimated total monitoring overhead: ~5,2F seconds" 1220 | (+ max-length 62 (max 0 (- max-cons-length 5))) "-" 1221 | max-length 1222 | (* 100 total-percent-time) 1223 | (* 100 total-percent-cons) 1224 | total-calls 1225 | max-cons-length " " 1226 | total-time total-consed 1227 | (/ (* *monitor-time-overhead* total-calls) 1228 | time-units-per-second) 1229 | *estimated-total-overhead*)) 1230 | 1231 | (defmethod results-table-footer ((fmt (eql :html)) 1232 | &key max-length max-cons-length 1233 | total-percent-time total-percent-cons 1234 | total-calls total-time total-consed) 1235 | (declare (ignore max-length max-cons-length)) 1236 | (format *trace-output* 1237 | "~&~ 1238 | 1239 | 1240 | 1241 | 1243 | 1244 | 1245 | 1246 | 1247 | 1248 | 1249 | 1252 | 1253 | 1254 | 1257 | 1258 | 1259 |
FunctionTimeConsCallsSec/CallCons per callTotal timeTotal cons
~A~6,2F~6,2F~7D~,6F~VD~8,3F~10D
Total 1242 | ~6,2F~6,2F~7D~8,3F~10D
1250 | Estimated monitoring overhead: ~5,2F seconds 1251 |
1255 | Estimated total monitoring overhead: ~5,2F seconds 1256 |
" 1260 | (* 100 total-percent-time) 1261 | (* 100 total-percent-cons) 1262 | total-calls 1263 | total-time total-consed 1264 | (/ (* *monitor-time-overhead* total-calls) 1265 | time-units-per-second) 1266 | *estimated-total-overhead*)) 1267 | 1268 | (defun display-monitoring-results (&optional (threshold 0.01) 1269 | (key :percent-time) 1270 | (ignore-no-calls t)) 1271 | (let ((max-length 8) ; Function header size 1272 | (max-cons-length 8) 1273 | (total-time 0.0) 1274 | (total-consed 0) 1275 | (total-calls 0) 1276 | (total-percent-time 0) 1277 | (total-percent-cons 0)) 1278 | (sort-results key) 1279 | (dolist (result *monitor-results*) 1280 | (when (or (zerop threshold) 1281 | (> (m-info-percent-time result) threshold)) 1282 | (setq max-length 1283 | (max max-length 1284 | (length (m-info-name result)))) 1285 | (setq max-cons-length 1286 | (max max-cons-length 1287 | (m-info-cons-per-call result))))) 1288 | (incf max-length 2) 1289 | (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10)))) 1290 | (results-table-header 1291 | *report-format* 1292 | :max-length max-length 1293 | :max-cons-length max-cons-length) 1294 | 1295 | (dolist (result *monitor-results*) 1296 | (when (or (zerop threshold) 1297 | (> (m-info-percent-time result) threshold)) 1298 | (results-table-row 1299 | *report-format* result 1300 | :max-length max-length 1301 | :max-cons-length max-cons-length) 1302 | (incf total-time (m-info-time result)) 1303 | (incf total-consed (m-info-cons result)) 1304 | (incf total-calls (m-info-calls result)) 1305 | (incf total-percent-time (m-info-percent-time result)) 1306 | (incf total-percent-cons (m-info-percent-cons result)))) 1307 | (results-table-footer 1308 | *report-format* 1309 | :max-length max-length 1310 | :max-cons-length max-cons-length 1311 | :total-percent-time total-percent-time 1312 | :total-percent-cons total-percent-cons 1313 | :total-calls total-calls 1314 | :total-time total-time 1315 | :total-consed total-consed) 1316 | (when (and (not ignore-no-calls) *no-calls*) 1317 | (setq *no-calls* (sort *no-calls* #'string<)) 1318 | (let ((num-no-calls (length *no-calls*))) 1319 | (if (> num-no-calls 20) 1320 | (format *trace-output* 1321 | "~%~@(~r~) monitored functions were not called. ~ 1322 | ~%See the variable ~s for a list." 1323 | num-no-calls '*no-calls*) 1324 | (format *trace-output* 1325 | "~%The following monitored functions were not called:~ 1326 | ~%~{~<~%~:; ~A~>~}~%" 1327 | *no-calls*)))) 1328 | (values))) 1329 | 1330 | (defun sort-results (&optional (key :percent-time)) 1331 | (setq *monitor-results* 1332 | (case key 1333 | (:function (sort *monitor-results* #'string> 1334 | :key #'m-info-name)) 1335 | ((:percent-time :time) (sort *monitor-results* #'> 1336 | :key #'m-info-time)) 1337 | ((:percent-cons :cons) (sort *monitor-results* #'> 1338 | :key #'m-info-cons)) 1339 | (:calls (sort *monitor-results* #'> 1340 | :key #'m-info-calls)) 1341 | (:time-per-call (sort *monitor-results* #'> 1342 | :key #'m-info-time-per-call)) 1343 | (:cons-per-call (sort *monitor-results* #'> 1344 | :key #'m-info-cons-per-call))))) 1345 | 1346 | ;;; *END OF FILE* 1347 | --------------------------------------------------------------------------------