metering.cl 33.3 KB
Newer Older
Daniel Kochmański's avatar
Daniel Kochmański committed
1
;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.;  -*- 
2
;;; metering.cl
Daniel Kochmański's avatar
Daniel Kochmański committed
3 4 5 6 7 8 9 10 11

;;; ****************************************************************
;;; METERING *******************************************************
;;; ****************************************************************

;;; ********************************
;;; Fix up the *features* list *****
;;; ********************************

12
(eval-when (compile load eval) #| nothing to fix |# )
Daniel Kochmański's avatar
Daniel Kochmański committed
13 14 15 16 17 18 19 20 21 22 23

;;; ********************************
;;; Packages ***********************
;;; ********************************

(defpackage "MONITOR" (:nicknames "MON") (:use "COMMON-LISP"))
(in-package "MONITOR")

(provide "monitor")

(export '(*monitored-functions*
24 25 26 27 28 29 30
          monitor monitor-all unmonitor monitor-form
          with-monitoring
          reset-monitoring-info reset-all-monitoring
          monitored
          report-monitoring
          display-monitoring-results
          monitoring-encapsulate monitoring-unencapsulate))
Daniel Kochmański's avatar
Daniel Kochmański committed
31 32 33 34


;;; Warn user if they're loading the source instead of compiling it first.
(eval-when (eval)
35
  (warn "This file should be compiled before loading for best results."))
Daniel Kochmański's avatar
Daniel Kochmański committed
36 37 38 39 40

;;; ********************************
;;; Version ************************
;;; ********************************

41
(defparameter *metering-version* "v3.2 2016-05-25"
Daniel Kochmański's avatar
Daniel Kochmański committed
42 43 44 45 46 47 48
  "Current version number/date for Metering.")


;;; ****************************************************************
;;; Implementation Dependent Definitions ***************************
;;; ****************************************************************

49 50 51 52
;;; ********************************
;;; Hacks for non-conforming CL ****
;;; ********************************

53
#-(or clisp)
54 55 56
(eval-when (compile load eval)
  (unless (fboundp 'fdefinition)

57
    (eval-when (load eval)
58 59 60 61 62 63 64 65
      (warn "This is not ANSI conforming Common Lisp. Expect problems."))

    (defun fdefinition (symbol)
      (symbol-function symbol))

    (defsetf fdefinition (name) (new-definition)
      `(setf (symbol-function ,name) ,new-definition))))

Daniel Kochmański's avatar
Daniel Kochmański committed
66 67 68 69 70 71
;;; ********************************
;;; Type Definitions ***************
;;; ********************************

(eval-when (compile load eval)
  (deftype time-type () 'unsigned-byte)
72
  (deftype consing-type () 'unsigned-byte))
Daniel Kochmański's avatar
Daniel Kochmański committed
73 74 75 76 77 78 79 80

;;; ********************************
;;; Timing Functions ***************
;;; ********************************
;;; The get-time function is called to find the total number of ticks since
;;; the beginning of time. time-units-per-second allows us to convert units
;;; to seconds.

81 82 83 84
(defconstant time-units-per-second internal-time-units-per-second)

(defmacro get-time ()
  `(the time-type (get-internal-run-time)))
Daniel Kochmański's avatar
Daniel Kochmański committed
85 86 87 88 89 90 91 92


;;; ********************************
;;; Consing Functions **************
;;; ********************************
;;; The get-cons macro is called to find the total number of bytes
;;; consed since the beginning of time.

93 94 95
#+cmu
(defmacro get-cons ()
  "The get-cons macro is called to find the total number of bytes
Daniel Kochmański's avatar
Daniel Kochmański committed
96
   consed since the beginning of time."
97
  '(the consing-type (ext:get-bytes-consed)))
98

99 100 101
#+clisp
(defmacro get-cons ()
  `(the consing-type
102 103 104 105
        (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
            (sys::%%time)
          (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
          (dpb space1 (byte 24 24) space2))))
106

107 108 109 110 111 112 113 114 115
#+clozure
(defmacro get-cons ()
  `(the consing-type (ccl::total-bytes-allocated)))

#+ecl
;; ECL has to compile the inlined C-code, otherwise it gets the generic
;; definition.
(eval-when (eval)
  (warn "No consing will be reported unless the package is compiled.")
116
  (defmacro get-cons ()
117 118
    (defmacro get-cons ()
      '(the consing-type 0))))
119

120 121 122
#+ecl
;; ECL has to compile the inlined C-code, otherwise it gets the generic
;; definition.
123 124 125
(eval-when (compile load)
  (defmacro get-cons ()
    `(the consing-type (ffi:c-inline () () :object
126 127
                         "ecl_make_unsigned_integer(GC_get_total_bytes())"
                         :one-liner t))))
128

129 130 131 132 133
#+sbcl
(defmacro get-cons ()
  `(the consing-type (sb-ext:get-bytes-consed)))

#-(or cmu clisp clozure ecl sbcl)
134 135 136 137
(eval-when (load eval)
  (warn "No consing will be reported unless a get-cons function is ~
           defined.")
  (defmacro get-cons () '(the consing-type 0)))
Daniel Kochmański's avatar
Daniel Kochmański committed
138 139 140 141 142 143 144 145 146 147 148 149 150

;;; ********************************
;;; Required Arguments *************
;;; ********************************
;;;
;;; Required (Fixed) vs Optional Args
;;;
;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
;;; number of required arguments, and use &rest to capture only non-required
;;; arguments.  The function Required-Arguments returns two values: the first
;;; is the number of required arguments, and the second is T iff there are any
;;; non-required arguments (e.g. &optional, &rest, &key).
#+cmu
151 152 153
(defun required-arguments (name)
  (let ((type (ext:info function type name)))
    (cond ((not (kernel:function-type-p type))
154 155 156 157 158 159 160 161 162 163
           (warn "No argument count information available for:~%  ~S~@
                  Allow for &rest arg consing."
                 name)
           (values 0 t))
          (t
           (values (length (kernel:function-type-required type))
                   (if (or (kernel:function-type-optional type)
                           (kernel:function-type-keyp type)
                           (kernel:function-type-rest type))
                       t nil))))))
Daniel Kochmański's avatar
Daniel Kochmański committed
164

165 166
;;; Allegro and Clozure Common Lisp
#+(or allegro clozure)
Daniel Kochmański's avatar
Daniel Kochmański committed
167
(defun required-arguments (name)
168
  (let* ((function (fdefinition name))
169
         (args #+allegro(excl::arglist function)
170
               #+clozure(ccl:arglist function))
Daniel Kochmański's avatar
Daniel Kochmański committed
171 172 173 174 175 176 177 178 179
         (pos (position-if #'(lambda (x)
                               (and (symbolp x)
                                    (let ((name (symbol-name x)))
                                      (and (>= (length name) 1)
                                           (char= (schar name 0)
                                                  #\&)))))
                           args)))
    (if pos
        (values pos t)
180
      (values (length args) nil))))
Daniel Kochmański's avatar
Daniel Kochmański committed
181

182
#+clisp
Daniel Kochmański's avatar
Daniel Kochmański committed
183
(defun required-arguments (name)
184
  (let ((function (fdefinition name)))
Daniel Kochmański's avatar
Daniel Kochmański committed
185 186 187
    (case (type-of function)
      (FUNCTION
       (if (compiled-function-p function)
188 189 190 191 192 193 194 195 196 197 198
           (multiple-value-bind (req-anz opt-anz rest-p key-p
                                         keyword-list allow-other-keys-p)
               (sys::signature function)
             (declare (ignore keyword-list allow-other-keys-p))
             (values req-anz (or (plusp opt-anz) rest-p key-p)))
           (let ((lambdalist (car (sys::%record-ref function 1))))
             (values (or (position-if #'(lambda (x)
                                          (member x lambda-list-keywords))
                                      lambdalist)
                         (length lambdalist))
                     (and (intersection lambdalist lambda-list-keywords) t)))))
Daniel Kochmański's avatar
Daniel Kochmański committed
199 200
      (COMPILED-FUNCTION
       (multiple-value-bind (name req-anz opt-anz rest-p
201 202 203 204 205 206
                                  keywords allow-other-keys)
           (sys::subr-info function)
         (declare (ignore allow-other-keys))
         (if name
             (values req-anz (or (plusp opt-anz) rest-p keywords))
             (values 0 t))))
Daniel Kochmański's avatar
Daniel Kochmański committed
207 208
      (T (values 0 t)))))

209
#-(or cmu clisp clozure allegro)
210 211 212 213 214 215 216
(eval-when (load eval)
  (warn
   "You may want to add an implementation-specific Required-Arguments ~
     function.")
  (defun required-arguments (name)
    (declare (ignore name))
    (values 0 t)))
Daniel Kochmański's avatar
Daniel Kochmański committed
217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262

#|
;;;Examples
(defun square (x) (* x x))
(defun square2 (x &optional y) (* x x y))
(defun test (x y &optional (z 3)) 3)
(defun test2 (x y &optional (z 3) &rest fred) 3)

(required-arguments 'square) => 1 nil
(required-arguments 'square2) => 1 t
(required-arguments 'test) => 2 t
(required-arguments 'test2) => 2 t
|#


;;; ****************************************************************
;;; Main METERING Code *********************************************
;;; ****************************************************************

;;; ********************************
;;; Global Variables ***************
;;; ********************************
(defvar *MONITOR-TIME-OVERHEAD* nil
  "The amount of time an empty monitored function costs.")
(defvar *MONITOR-CONS-OVERHEAD* nil
  "The amount of cons an empty monitored function costs.")

(defvar *TOTAL-TIME* 0
  "Total amount of time monitored so far.")
(defvar *TOTAL-CONS* 0
  "Total amount of consing monitored so far.")
(defvar *TOTAL-CALLS* 0
  "Total number of calls monitored so far.")
(proclaim '(type time-type *total-time*))
(proclaim '(type consing-type *total-cons*))
(proclaim '(fixnum *total-calls*))

;;; ********************************
;;; Accessor Functions *************
;;; ********************************
;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables
;;; containing closures.
(defmacro PLACE-FUNCTION (function-place)
  "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
if it isn't a symbol, to allow monitoring of closures located in
variables/arrays/structures."
263 264 265
  `(if (fboundp ,function-place)
       (fdefinition ,function-place)
       (eval ,function-place)))
Daniel Kochmański's avatar
Daniel Kochmański committed
266 267 268

(defsetf PLACE-FUNCTION (function-place) (function)
  "Set the function in FUNCTION-PLACE to FUNCTION."
269 270
  `(if (fboundp ,function-place)
       (setf (fdefinition ,function-place) ,function)
Daniel Kochmański's avatar
Daniel Kochmański committed
271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298
       (eval '(setf ,function-place ',function))))

(defun PLACE-FBOUNDP (function-place)
  "Test to see if FUNCTION-PLACE is a function."
  ;; probably should be 
  #|(or (and (symbolp function-place)(fboundp function-place))
      (functionp (place-function function-place)))|#
  (if (symbolp function-place)
      (fboundp function-place)
      (functionp (place-function function-place))))

(defun PLACE-MACROP (function-place)
  "Test to see if FUNCTION-PLACE is a macro."
  (when (symbolp function-place)
    (macro-function function-place)))

;;; ********************************
;;; Measurement Tables *************
;;; ********************************
(defvar *monitored-functions* nil
  "List of monitored symbols.")

;;; We associate a METERING-FUNCTIONS structure with each monitored function
;;; name or other closure. This holds the functions that we call to manipulate
;;; the closure which implements the encapsulation.
;;;
(defstruct metering-functions
  (name nil)
299
  (old-definition (error "Missing required keyword argument :old-definition")
300
                  :type function)
301
  (new-definition (error "Missing required keyword argument :new-definition")
302
                  :type function)
303
  (read-metering  (error "Missing required keyword argument :read-metering")
304
                  :type function)
305
  (reset-metering (error "Missing required keyword argument :reset-metering")
306
                  :type function))
Daniel Kochmański's avatar
Daniel Kochmański committed
307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327

;;; In general using hash tables in time-critical programs is a bad idea,
;;; because when one has to grow the table and rehash everything, the
;;; timing becomes grossly inaccurate. In this case it is not an issue
;;; because all inserting of entries in the hash table occurs before the
;;; timing commences. The only circumstance in which this could be a 
;;; problem is if the lisp rehashes on the next reference to the table,
;;; instead of when the entry which forces a rehash was inserted. 
;;;
;;; Note that a similar kind of problem can occur with GC, which is why
;;; one should turn off GC when monitoring code. 
;;;
(defvar *monitor* (make-hash-table :test #'equal)
  "Hash table in which METERING-FUNCTIONS structures are stored.")
(defun get-monitor-info (name)
  (gethash name *monitor*))
(defsetf get-monitor-info (name) (info)
  `(setf (gethash ,name *monitor*) ,info))

(defun MONITORED (function-place)
  "Test to see if a FUNCTION-PLACE is monitored."
328
  (and (place-fboundp function-place)   ; this line necessary?
Daniel Kochmański's avatar
Daniel Kochmański committed
329 330 331 332 333 334 335 336 337 338
       (get-monitor-info function-place)))

(defun reset-monitoring-info (name)
  "Reset the monitoring info for the specified function."
  (let ((finfo (get-monitor-info name)))
    (when finfo
      (funcall (metering-functions-reset-metering finfo)))))
(defun reset-all-monitoring () 
  "Reset monitoring info for all functions."
  (setq *total-time* 0
339 340
        *total-cons* 0
        *total-calls* 0)
Daniel Kochmański's avatar
Daniel Kochmański committed
341 342 343 344 345 346 347 348 349
  (dolist (symbol *monitored-functions*)
    (when (monitored symbol)
      (reset-monitoring-info symbol))))

(defun monitor-info-values (name &optional (nested :exclusive) warn)
  "Returns monitoring information values for the named function,
adjusted for overhead."
  (let ((finfo (get-monitor-info name)))
    (if finfo
350 351 352 353 354 355 356 357
        (multiple-value-bind (inclusive-time inclusive-cons
                                             exclusive-time exclusive-cons
                                             calls nested-calls)
            (funcall (metering-functions-read-metering finfo))
          (unless (or (null warn)
                      (eq (place-function name)
                          (metering-functions-new-definition finfo)))
            (warn "Funtion ~S has been redefined, so times may be inaccurate.~@
Daniel Kochmański's avatar
Daniel Kochmański committed
358
                   MONITOR it again to record calls to the new definition."
359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379
                  name))
          (case nested
            (:exclusive (values calls
                                nested-calls
                                (- exclusive-time
                                   (* calls *monitor-time-overhead*))
                                (- exclusive-cons
                                   (* calls *monitor-cons-overhead*))))
            ;; In :inclusive mode, subtract overhead for all the
            ;; called functions as well. Nested-calls includes the
            ;; calls of the function as well. [Necessary 'cause of
            ;; functions which call themselves recursively.]
            (:inclusive (values calls
                                nested-calls
                                (- inclusive-time
                                   (* nested-calls ;(+ calls)
                                      *monitor-time-overhead*))
                                (- inclusive-cons
                                   (* nested-calls ;(+ calls)
                                      *monitor-cons-overhead*))))))
        (values 0 0 0 0))))
Daniel Kochmański's avatar
Daniel Kochmański committed
380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397

;;; ********************************
;;; Encapsulate ********************
;;; ********************************
(eval-when (compile load eval)
;; Returns a lambda expression for a function that, when called with the
;; function name, will set up that function for metering.
;;
;; A function is monitored by replacing its definition with a closure
;; created by the following function. The closure records the monitoring
;; data, and updates the data with each call of the function.
;;
;; Other closures are used to read and reset the data.
(defun make-monitoring-encapsulation (min-args optionals-p)
  (let (required-args)
    (dotimes (i min-args) (push (gensym) required-args))
    `(lambda (name)
       (let ((inclusive-time 0)
398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491
             (inclusive-cons 0)
             (exclusive-time 0)
             (exclusive-cons 0)
             (calls 0)
             (nested-calls 0)
             (old-definition (place-function name)))
         (declare (type time-type inclusive-time)
                  (type time-type exclusive-time)
                  (type consing-type inclusive-cons)
                  (type consing-type exclusive-cons)
                  (fixnum calls)
                  (fixnum nested-calls))
         (pushnew name *monitored-functions*)

         (setf (place-function name)
               #'(lambda (,@required-args
                          ,@(when optionals-p `(&rest optional-args)))
                   ,(when optionals-p
                          ;; &rest optional-args can be stack allocated
                          `(declare (dynamic-extent optional-args)))
                   (let ((prev-total-time *total-time*)
                         (prev-total-cons *total-cons*)
                         (prev-total-calls *total-calls*)
;                        (old-time inclusive-time)
;                        (old-cons inclusive-cons)
;                        (old-nested-calls nested-calls)
                         (start-time (get-time))
                         (start-cons (get-cons)))
                     (declare (type time-type prev-total-time)
                              (type time-type start-time)
                              (type consing-type prev-total-cons)
                              (type consing-type start-cons)
                              (fixnum prev-total-calls))
                     (multiple-value-prog1
                         ,(if optionals-p
                              `(apply old-definition
                                      ,@required-args optional-args)
                              `(funcall old-definition ,@required-args))
                       (let ((delta-time (- (get-time) start-time))
                             (delta-cons (- (get-cons) start-cons)))
                         ;; Calls
                         (incf calls)
                         (incf *total-calls*)
                            ;;; nested-calls includes this call
                         (incf nested-calls (the fixnum
                                                 (- *total-calls*
                                                    prev-total-calls)))
;                        (setf nested-calls (+ old-nested-calls
;                                              (- *total-calls*
;                                                 prev-total-calls)))
                         ;; Time
                            ;;; Problem with inclusive time is that it
                            ;;; currently doesn't add values from recursive
                            ;;; calls to the same function. Change the
                            ;;; setf to an incf to fix this?
                         (incf inclusive-time (the time-type delta-time))
;                        (setf inclusive-time (+ delta-time old-time))
                         (incf exclusive-time (the time-type
                                                   (+ delta-time
                                                      (- prev-total-time
                                                         *total-time*))))
                         (setf *total-time* (the time-type
                                                 (+ delta-time
                                                    prev-total-time)))
                         ;; Consing
                         (incf inclusive-cons (the consing-type delta-cons))
;                        (setf inclusive-cons (+ delta-cons old-cons))
                         (incf exclusive-cons (the consing-type
                                                   (+ delta-cons
                                                      (- prev-total-cons
                                                         *total-cons*))))
                         (setf *total-cons*
                               (the consing-type
                                    (+ delta-cons prev-total-cons))))))))
         (setf (get-monitor-info name)
               (make-metering-functions
                :name name
                :old-definition old-definition
                :new-definition (place-function name)
                :read-metering #'(lambda ()
                                   (values inclusive-time
                                           inclusive-cons
                                           exclusive-time
                                           exclusive-cons
                                           calls
                                           nested-calls))
                :reset-metering #'(lambda ()
                                    (setq inclusive-time 0
                                          inclusive-cons 0
                                          exclusive-time 0
                                          exclusive-cons 0
                                          calls 0
                                          nested-calls 0)
                                    t)))))))
Daniel Kochmański's avatar
Daniel Kochmański committed
492 493 494 495 496 497 498 499 500 501 502 503 504 505 506
);; End of EVAL-WHEN

;;; For efficiency reasons, we precompute the encapsulation functions
;;; for a variety of combinations of argument structures 
;;; (min-args . optional-p). These are stored in the following hash table
;;; along with any new ones we encounter. Since we're now precomputing
;;; closure functions for common argument signatures, this eliminates
;;; the former need to call COMPILE for each monitored function.  
(eval-when (compile eval)
   (defconstant precomputed-encapsulations 8))

(defvar *existing-encapsulations* (make-hash-table :test #'equal))
(defun find-encapsulation (min-args optionals-p)
  (or (gethash (cons min-args optionals-p) *existing-encapsulations*)
      (setf (gethash (cons min-args optionals-p) *existing-encapsulations*)
507 508
            (compile nil
                     (make-monitoring-encapsulation min-args optionals-p)))))
Daniel Kochmański's avatar
Daniel Kochmański committed
509 510

(macrolet ((frob ()
511 512 513 514 515 516 517 518 519
             (let ((res ()))
               (dotimes (i precomputed-encapsulations)
                 (push `(setf (gethash '(,i . nil) *existing-encapsulations*)
                              #',(make-monitoring-encapsulation i nil))
                       res)
                 (push `(setf (gethash '(,i . t) *existing-encapsulations*)
                              #',(make-monitoring-encapsulation i t))
                       res))
               `(progn ,@res))))
Daniel Kochmański's avatar
Daniel Kochmański committed
520 521 522 523 524 525
  (frob))

(defun monitoring-encapsulate (name &optional warn)
  "Monitor the function Name. If already monitored, unmonitor first."
  ;; Saves the current definition of name and inserts a new function which
  ;; returns the result of evaluating body. 
526 527 528 529 530 531 532 533 534 535 536 537 538 539
  (cond ((not (place-fboundp name))     ; not a function
         (when warn
           (warn "Ignoring undefined function ~S." name)))
        ((place-macrop name)            ; a macro
         (when warn
           (warn "Ignoring macro ~S." name)))
        (t                              ; tis a function
         (when (get-monitor-info name) ; monitored
           (when warn
             (warn "~S already monitored, so unmonitoring it first." name))
           (monitoring-unencapsulate name))
         (multiple-value-bind (min-args optionals-p)
             (required-arguments name)
           (funcall (find-encapsulation min-args optionals-p) name)))))
Daniel Kochmański's avatar
Daniel Kochmański committed
540 541 542 543

(defun monitoring-unencapsulate (name &optional warn)
  "Removes monitoring encapsulation code from around Name."
  (let ((finfo (get-monitor-info name)))
544
    (when finfo                         ; monitored
Daniel Kochmański's avatar
Daniel Kochmański committed
545 546
      (remprop name 'metering-functions)
      (setq *monitored-functions* 
547
            (remove name *monitored-functions* :test #'equal))
Daniel Kochmański's avatar
Daniel Kochmański committed
548
      (if (eq (place-function name)
549 550 551 552 553 554
              (metering-functions-new-definition finfo))
          (setf (place-function name)
                (metering-functions-old-definition finfo))
          (when warn
            (warn "Preserving current definition of redefined function ~S."
                  name))))))
Daniel Kochmański's avatar
Daniel Kochmański committed
555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572
    
;;; ********************************
;;; Main Monitoring Functions ******
;;; ********************************
(defmacro MONITOR (&rest names)
  "Monitor the named functions. As in TRACE, the names are not evaluated.
   If a function is already monitored, then unmonitor and remonitor (useful
   to notice function redefinition). If a name is undefined, give a warning
   and ignore it. See also unmonitor, report-monitoring, 
   display-monitoring-results and reset-time."
  `(progn
     ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names)
     *monitored-functions*))

(defmacro UNMONITOR (&rest names)
  "Remove the monitoring on the named functions. 
   Names defaults to the list of all currently monitored functions."
  `(dolist (name ,(if names `',names '*monitored-functions*) (values))
573
     (monitoring-unencapsulate name)))
Daniel Kochmański's avatar
Daniel Kochmański committed
574 575 576 577

(defun MONITOR-ALL (&optional (package *package*))
  "Monitor all functions in the specified package."
  (let ((package (if (symbolp package)
578 579
                     (find-package package)
                     package)))
Daniel Kochmański's avatar
Daniel Kochmański committed
580 581
    (do-symbols (symbol package)
      (when (eq (symbol-package symbol) package)
582
        (monitoring-encapsulate symbol)))))
Daniel Kochmański's avatar
Daniel Kochmański committed
583 584

(defmacro MONITOR-FORM (form 
585 586
                        &optional (nested :exclusive) (threshold 0.01)
                        (key :percent-time))
Daniel Kochmański's avatar
Daniel Kochmański committed
587 588 589 590 591
  "Monitor the execution of all functions in the current package
during the execution of FORM.  All functions that are executed above
THRESHOLD % will be reported."
  `(unwind-protect
       (progn
592 593 594 595 596
         (monitor-all)
         (reset-all-monitoring)
         (prog1
             (time ,form)
           (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls)))
Daniel Kochmański's avatar
Daniel Kochmański committed
597 598 599
     (unmonitor)))

(defmacro WITH-MONITORING ((&rest functions)
600 601 602 603
                           (&optional (nested :exclusive)
                                      (threshold 0.01)
                                      (key :percent-time))
                           &body body)
Daniel Kochmański's avatar
Daniel Kochmański committed
604 605 606
  "Monitor the specified functions during the execution of the body."
  `(unwind-protect
       (progn
607 608 609 610 611
         (dolist (fun ',functions)
           (monitoring-encapsulate fun))
         (reset-all-monitoring)
         ,@body
         (report-monitoring :all ,nested ,threshold ,key))
Daniel Kochmański's avatar
Daniel Kochmański committed
612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629
     (unmonitor)))

;;; ********************************
;;; Overhead Calculations **********
;;; ********************************
(defconstant overhead-iterations 5000
  "Number of iterations over which the timing overhead is averaged.")

;;; Perhaps this should return something to frustrate clever compilers.
(defun STUB-FUNCTION (x)
  (declare (ignore x))
  nil)
(proclaim '(notinline stub-function))

(defun SET-MONITOR-OVERHEAD ()
  "Determines the average overhead of monitoring by monitoring the execution
of an empty function many times." 
  (setq *monitor-time-overhead* 0
630
        *monitor-cons-overhead* 0)
Daniel Kochmański's avatar
Daniel Kochmański committed
631 632 633
  (stub-function nil)
  (monitor stub-function)
  (reset-all-monitoring)
634
  (let ((overhead-function (fdefinition 'stub-function)))
Daniel Kochmański's avatar
Daniel Kochmański committed
635 636 637 638 639 640
    (dotimes (x overhead-iterations)
      (funcall overhead-function overhead-function)))
;  (dotimes (x overhead-iterations)
;    (stub-function nil))
  (let ((fiter (float overhead-iterations)))
    (multiple-value-bind (calls nested-calls time cons)
641
        (monitor-info-values 'stub-function)
Daniel Kochmański's avatar
Daniel Kochmański committed
642
      (declare (ignore calls nested-calls))
643
      (setq *monitor-time-overhead* (truncate (/ time fiter))
644
            *monitor-cons-overhead* (truncate (/ cons fiter)))))
Daniel Kochmański's avatar
Daniel Kochmański committed
645 646 647 648 649 650 651 652 653 654 655 656 657 658
  (unmonitor stub-function))
(set-monitor-overhead)

;;; ********************************
;;; Report Data ********************
;;; ********************************
(defvar *monitor-results* nil
  "A table of monitoring statistics is stored here.")
(defvar *no-calls* nil
  "A list of monitored functions which weren't called.")
(defvar *estimated-total-overhead* 0)
(proclaim '(type time-type *estimated-total-overhead*))

(defstruct (monitoring-info 
659 660 661 662 663
            (:conc-name m-info-)
            (:constructor make-monitoring-info
                          (name calls time cons
                                percent-time percent-cons
                                time-per-call cons-per-call)))
Daniel Kochmański's avatar
Daniel Kochmański committed
664 665 666 667 668 669 670 671 672 673
  name
  calls
  time
  cons
  percent-time
  percent-cons
  time-per-call
  cons-per-call)

(defun REPORT-MONITORING (&optional names 
674 675 676 677
                                    (nested :exclusive)
                                    (threshold 0.01)
                                    (key :percent-time)
                                    ignore-no-calls)
Daniel Kochmański's avatar
Daniel Kochmański committed
678 679 680 681 682 683 684 685 686
  "Report the current monitoring state.
The percentage of the total time spent executing unmonitored code
in each function (:exclusive mode), or total time (:inclusive mode)
will be printed together with the number of calls and
the unmonitored time per call.  Functions that have been executed
below THRESHOLD % of the time will not be reported."
  (when (or (null names) (eq names :all)) (setq names *monitored-functions*))

  (let ((total-time 0)
687 688
        (total-cons 0)
        (total-calls 0))
Daniel Kochmański's avatar
Daniel Kochmański committed
689 690 691
    ;; Compute overall time and consing.
    (dolist (name names)
      (multiple-value-bind (calls nested-calls time cons)
692 693 694 695 696
          (monitor-info-values name nested :warn)
        (declare (ignore nested-calls))
        (incf total-calls calls)
        (incf total-time time)
        (incf total-cons cons)))
Daniel Kochmański's avatar
Daniel Kochmański committed
697
    ;; Total overhead.
698 699 700
    (setq *estimated-total-overhead*
          (/ (* *monitor-time-overhead* total-calls)
             time-units-per-second))
Daniel Kochmański's avatar
Daniel Kochmański committed
701 702
    ;; Assemble data for only the specified names (all monitored functions)
    (if (zerop total-time)
703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729
        (format *trace-output* "Not enough execution time to monitor.")
        (progn
          (setq *monitor-results* nil *no-calls* nil)
          (dolist (name names)
            (multiple-value-bind (calls nested-calls time cons)
                (monitor-info-values name nested)
              (declare (ignore nested-calls))
              (when (minusp time) (setq time 0.0))
              (when (minusp cons) (setq cons 0.0))
              (if (zerop calls)
                  (push (if (symbolp name)
                            (symbol-name name)
                            (format nil "~S" name))
                        *no-calls*)
                  (push (make-monitoring-info
                         (format nil "~S" name) ; name
                         calls          ; calls
                         (/ time (float time-units-per-second)) ; time in secs
                         (round cons)   ; consing
                         (/ time (float total-time)) ; percent-time
                         (if (zerop total-cons) 0
                             (/ cons (float total-cons))) ; percent-cons
                         (/ (/ time (float calls)) ; time-per-call
                            time-units-per-second) ; sec/call
                         (round (/ cons (float calls)))) ; cons-per-call
                        *monitor-results*))))
          (display-monitoring-results threshold key ignore-no-calls)))))
Daniel Kochmański's avatar
Daniel Kochmański committed
730

731 732 733 734
(defun display-monitoring-results (&optional
                                     (threshold 0.01)
                                     (key :percent-time)
                                     (ignore-no-calls t))
735 736 737 738 739 740
  (let ((max-length 8)                  ; Function header size
        (total-time 0.0)
        (total-consed 0)
        (total-calls 0)
        (total-percent-time 0)
        (total-percent-cons 0))
Daniel Kochmański's avatar
Daniel Kochmański committed
741 742 743
    (sort-results key)
    (dolist (result *monitor-results*)
      (when (or (zerop threshold)
744 745 746 747
                (> (m-info-percent-time result) threshold))
        (setq max-length
              (max max-length
                   (length (m-info-name result))))))
Daniel Kochmański's avatar
Daniel Kochmański committed
748 749
    (incf max-length 2)
    (format *trace-output*
750 751 752
            "~&        ~VT                              Cons~
             ~&        ~VT%     %                       Per      Total   Total~
             ~&Function~VTTime  Cons  Calls  Sec/Call   Call     Time    Cons~
Daniel Kochmański's avatar
Daniel Kochmański committed
753
             ~&~V,,,'-A"
754 755
            max-length max-length max-length
            (+ max-length 53) "-")
Daniel Kochmański's avatar
Daniel Kochmański committed
756 757
    (dolist (result *monitor-results*)
      (when (or (zerop threshold)
758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774
                (> (m-info-percent-time result) threshold))
        (format *trace-output*
                "~&~A:~VT~,2F  ~,2F  ~5D  ~,6F  ~5D  ~,6F  ~6D"
                (m-info-name result)
                max-length
                (m-info-percent-time result)
                (m-info-percent-cons result)
                (m-info-calls result)
                (m-info-time-per-call result)
                (m-info-cons-per-call result)
                (m-info-time result)
                (m-info-cons result))
        (incf total-time (m-info-time result))
        (incf total-consed (m-info-cons result))
        (incf total-calls (m-info-calls result))
        (incf total-percent-time (m-info-percent-time result))
        (incf total-percent-cons (m-info-percent-cons result))))
Daniel Kochmański's avatar
Daniel Kochmański committed
775
    (format *trace-output* 
776 777
            "~&~V,,,'-A~
            ~&TOTAL:~VT~,2F  ~,2F  ~5D                   ~,6F  ~6D~
Daniel Kochmański's avatar
Daniel Kochmański committed
778 779
            ~&Estimated monitoring overhead: ~4,2F seconds~
            ~&Estimated total monitoring overhead: ~4,2F seconds"
780 781 782 783 784 785 786
            (+ max-length 53) "-"
            max-length
            total-percent-time total-percent-cons
            total-calls total-time total-consed
            (/ (* *monitor-time-overhead* total-calls)
               time-units-per-second)
            *estimated-total-overhead*)
Daniel Kochmański's avatar
Daniel Kochmański committed
787 788 789
    (when (and (not ignore-no-calls) *no-calls*)
      (setq *no-calls* (sort *no-calls* #'string<))
      (let ((num-no-calls (length *no-calls*)))
790 791 792
        (if (> num-no-calls 20)
            (format *trace-output*
                    "~%~@(~r~) monitored functions were not called. ~
Daniel Kochmański's avatar
Daniel Kochmański committed
793
                      ~%See the variable mon::*no-calls* for a list."
794 795 796
                    num-no-calls)
            (format *trace-output*
                    "~%The following monitored functions were not called:~
Daniel Kochmański's avatar
Daniel Kochmański committed
797
                ~%~{~<~%~:; ~A~>~}~%"
798
                    *no-calls*))))
Daniel Kochmański's avatar
Daniel Kochmański committed
799 800 801 802
    (values)))

(defun sort-results (&optional (key :percent-time))
  (setq *monitor-results* 
803 804 805 806 807 808 809 810 811 812 813 814 815
        (case key
          (:function             (sort *monitor-results* #'string>
                                       :key #'m-info-name))
          ((:percent-time :time) (sort *monitor-results* #'>
                                       :key #'m-info-time))
          ((:percent-cons :cons) (sort *monitor-results* #'>
                                       :key #'m-info-cons))
          (:calls                (sort *monitor-results* #'>
                                       :key #'m-info-calls))
          (:time-per-call        (sort *monitor-results* #'>
                                       :key #'m-info-time-per-call))
          (:cons-per-call        (sort *monitor-results* #'>
                                       :key #'m-info-cons-per-call)))))
Daniel Kochmański's avatar
Daniel Kochmański committed
816 817

;;; *END OF FILE*