1;;;; This software is part of the SBCL system. See the README file for 2;;;; more information. 3;;;; 4;;;; This software is derived from the CMU CL system, which was 5;;;; written at Carnegie Mellon University and released into the 6;;;; public domain. The software is in the public domain and is 7;;;; provided with absolutely no warranty. See the COPYING and CREDITS 8;;;; files for more information. 9 10(in-package "SB-PROFILE") ; (SB-, not SB!, since we're built in warm load.) 11 12 13;;;; COUNTER object 14;;;; 15;;;; Thread safe, and reasonably fast: in common case increment is just an 16;;;; ATOMIC-INCF, in overflow case grab a lock and increment overflow counter. 17 18(declaim (inline make-counter)) 19(defstruct (counter (:constructor make-counter) (:copier nil)) 20 (word 0 :type sb-vm:word) 21 (overflow 0 :type unsigned-byte)) 22 23(defun incf-counter (counter delta) 24 ;; When running multi-threaded we can easily get negative numbers for the 25 ;; cons-counter. Don't count them at all. 26 (when (plusp delta) 27 (labels ((%incf-overflow (&optional (n 1)) 28 ;; Overflow-counter can run into bignums... so we need to loop 29 ;; around CAS till the increment succeeds. 30 (loop for old = (counter-overflow counter) 31 until (eq old (compare-and-swap (counter-overflow counter) 32 old (+ old n))))) 33 (%incf (d) 34 ;; Increment the word-sized counter. If it overflows, record the 35 ;; overflow. 36 (let ((prev (atomic-incf (counter-word counter) d))) 37 (when (< (logand most-positive-word (+ prev d)) prev) 38 (%incf-overflow))))) 39 ;; DELTA can potentially be a bignum -- cut it down to word-size. 40 (unless (typep delta 'sb-vm:word) 41 (multiple-value-bind (n r) (truncate delta (1+ most-positive-word)) 42 (%incf-overflow n) 43 (setf delta r))) 44 ;; ATOMIC-INCF can at most handle SIGNED-WORD: if DELTA doesn't fit that, 45 ;; DELTA/2 will. 46 (if (typep delta 'sb-vm:signed-word) 47 (%incf delta) 48 ;; ...and if delta is still too big, split it into four parts: they 49 ;; are guaranteed to fit into a signed word. 50 (multiple-value-bind (n r) (truncate delta 2) 51 (%incf n) 52 (%incf n) 53 (%incf r))))) 54 counter) 55 56(defun counter-count (counter) 57 (+ (counter-word counter) 58 (* (counter-overflow counter) (1+ most-positive-word)))) 59 60;;;; High resolution timer 61 62;;; FIXME: High resolution this is not. Build a microsecond-accuracy version 63;;; on top of unix-getrusage, maybe. 64 65(defconstant +ticks-per-second+ internal-time-units-per-second) 66 67(declaim (inline get-internal-ticks)) 68(defun get-internal-ticks () 69 (get-internal-run-time)) 70 71;;;; global data structures 72 73;;; We associate a PROFILE-INFO structure with each profiled function 74;;; name. This holds the functions that we call to manipulate the 75;;; closure which implements the encapsulation. 76(defvar *profiled-fun-name->info* 77 (make-hash-table 78 ;; EQL testing isn't good enough for generalized function names 79 ;; like (SETF FOO). 80 :test 'equal 81 :synchronized t)) 82(defstruct (profile-info (:copier nil)) 83 (name (missing-arg) :read-only t) 84 (encapsulated-fun (missing-arg) :type function :read-only t) 85 (encapsulation-fun (missing-arg) :type function :read-only t) 86 (read-stats-fun (missing-arg) :type function :read-only t) 87 (clear-stats-fun (missing-arg) :type function :read-only t)) 88 89;;; These variables are used to subtract out the time and consing for 90;;; recursive and other dynamically nested profiled calls. The total 91;;; resource consumed for each nested call is added into the 92;;; appropriate variable. When the outer function returns, these 93;;; amounts are subtracted from the total. 94(declaim (counter *enclosed-ticks* *enclosed-consing*)) 95(defvar *enclosed-ticks*) 96(defvar *enclosed-consing*) 97 98;;; This variable is also used to subtract out time for nested 99;;; profiled calls. The time inside the profile wrapper call -- 100;;; between its two calls to GET-INTERNAL-TICKS -- is accounted 101;;; for by the *ENCLOSED-TIME* variable. However, there's also extra 102;;; overhead involved, before we get to the first call to 103;;; GET-INTERNAL-TICKS, and after we get to the second call. By 104;;; keeping track of the count of enclosed profiled calls, we can try 105;;; to compensate for that. 106(declaim (counter *enclosed-profiles*)) 107(defvar *enclosed-profiles*) 108 109(declaim (counter *enclosed-gc-run-time*)) 110(defvar *enclosed-gc-run-time*) 111 112;;; the encapsulated function we're currently computing profiling data 113;;; for, recorded so that we can detect the problem of 114;;; PROFILE-computing machinery calling a function which has itself 115;;; been PROFILEd 116(defvar *computing-profiling-data-for*) 117 118;;; the components of profiling overhead 119(defstruct (overhead (:copier nil)) 120 ;; the number of ticks a bare function call takes. This is 121 ;; factored into the other overheads, but not used for itself. 122 (call (missing-arg) :type single-float :read-only t) 123 ;; the number of ticks that will be charged to a profiled 124 ;; function due to the profiling code 125 (internal (missing-arg) :type single-float :read-only t) 126 ;; the number of ticks of overhead for profiling that a single 127 ;; profiled call adds to the total runtime for the program 128 (total (missing-arg) :type single-float :read-only t)) 129(defvar *overhead*) 130(declaim (type overhead *overhead*)) 131(makunbound '*overhead*) ; in case we reload this file when tweaking 132 133;;;; profile encapsulations 134 135;;; Return a collection of closures over the same lexical context, 136;;; (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN). 137;;; 138;;; ENCAPSULATION-FUN is a plug-in replacement for ENCAPSULATED-FUN, 139;;; which updates statistics whenever it's called. 140;;; 141;;; READ-STATS-FUN returns the statistics: 142;;; (VALUES COUNT TIME CONSING PROFILE). 143;;; COUNT is the count of calls to ENCAPSULATION-FUN. TICKS is 144;;; the total number of ticks spent in ENCAPSULATED-FUN. 145;;; CONSING is the total consing of ENCAPSULATION-FUN. PROFILE is the 146;;; number of calls to the profiled function, stored for the purposes 147;;; of trying to estimate that part of profiling overhead which occurs 148;;; outside the interval between the profile wrapper function's timer 149;;; calls. 150;;; 151;;; CLEAR-STATS-FUN clears the statistics. 152;;; 153;;; (The reason for implementing this as coupled closures, with the 154;;; counts built into the lexical environment, is that we hope this 155;;; will minimize profiling overhead.) 156(defun profile-encapsulation-lambdas () 157 (let* ((count (make-counter)) 158 (ticks (make-counter)) 159 (consing (make-counter)) 160 (profiles (make-counter)) 161 (gc-run-time (make-counter))) 162 (declare (counter count ticks consing profiles gc-run-time)) 163 (values 164 ;; ENCAPSULATION-FUN 165 (lambda (function &rest args) 166 (declare (optimize speed safety) 167 (function function)) 168 ;; Make sure that we're not recursing infinitely. 169 (when (boundp '*computing-profiling-data-for*) 170 (unprofile-all) ; to avoid further recursion 171 (error "~@<When computing profiling data for ~S, the profiled ~ 172 function ~S was called. To get out of this infinite recursion, all ~ 173 functions have been unprofiled. (Since the profiling system evidently ~ 174 uses ~S in its computations, it looks as though it's a bad idea to ~ 175 profile it.)~:@>" 176 *computing-profiling-data-for* function function)) 177 (incf-counter count 1) 178 (let ((dticks 0) 179 (dconsing 0) 180 (inner-enclosed-profiles 0) 181 (dgc-run-time 0)) 182 (declare (truly-dynamic-extent dticks dconsing inner-enclosed-profiles)) 183 (unwind-protect 184 (let ((start-ticks (get-internal-ticks)) 185 (start-gc-run-time *gc-run-time*) 186 (*enclosed-ticks* (make-counter)) 187 (*enclosed-consing* (make-counter)) 188 (*enclosed-profiles* (make-counter)) 189 (nbf0 *n-bytes-freed-or-purified*) 190 (dynamic-usage-0 (sb-kernel:dynamic-usage)) 191 (*enclosed-gc-run-time* (make-counter))) 192 (declare (dynamic-extent *enclosed-ticks* *enclosed-consing* 193 *enclosed-profiles* *enclosed-gc-run-time*)) 194 (unwind-protect 195 (apply function args) 196 (let ((*computing-profiling-data-for* function) 197 (dynamic-usage-1 (sb-kernel:dynamic-usage))) 198 (setf dticks (- (get-internal-ticks) start-ticks) 199 dconsing (if (eql *n-bytes-freed-or-purified* nbf0) 200 ;; common special case where we can avoid 201 ;; bignum arithmetic 202 (- dynamic-usage-1 dynamic-usage-0) 203 ;; general case 204 (- (get-bytes-consed) nbf0 dynamic-usage-0)) 205 inner-enclosed-profiles (counter-count *enclosed-profiles*) 206 dgc-run-time (- *gc-run-time* start-gc-run-time)) 207 (incf-counter ticks (- dticks (counter-count *enclosed-ticks*))) 208 (incf-counter gc-run-time (- dgc-run-time (counter-count *enclosed-gc-run-time*))) 209 (incf-counter consing (- dconsing (counter-count *enclosed-consing*))) 210 (incf-counter profiles inner-enclosed-profiles)))) 211 (when (boundp '*enclosed-ticks*) 212 (incf-counter *enclosed-ticks* dticks) 213 (incf-counter *enclosed-consing* dconsing) 214 (incf-counter *enclosed-profiles* (1+ inner-enclosed-profiles)) 215 (incf-counter *enclosed-gc-run-time* dgc-run-time))))) 216 ;; READ-STATS-FUN 217 (lambda () 218 (values (counter-count count) 219 (counter-count ticks) 220 (counter-count consing) 221 (counter-count profiles) 222 (counter-count gc-run-time))) 223 ;; CLEAR-STATS-FUN 224 (lambda () 225 (setf count (make-counter) 226 ticks (make-counter) 227 consing (make-counter) 228 profiles (make-counter) 229 gc-run-time (make-counter)))))) 230 231;;;; interfaces 232 233;;; A symbol or (SETF FOO) list names a function, a string names all 234;;; the functions named by symbols in the named package. 235(defun mapc-on-named-funs (function names) 236 (dolist (name names) 237 (etypecase name 238 (symbol (funcall function name)) 239 (list 240 (legal-fun-name-or-type-error name) 241 ;; Then we map onto it. 242 (funcall function name)) 243 (string (let ((package (find-undeleted-package-or-lose name))) 244 (do-symbols (symbol package) 245 (when (eq (symbol-package symbol) package) 246 (when (and (fboundp symbol) 247 (not (macro-function symbol)) 248 (not (special-operator-p symbol))) 249 (funcall function symbol)) 250 (let ((setf-name `(setf ,symbol))) 251 (when (fboundp setf-name) 252 (funcall function setf-name))))))))) 253 (values)) 254 255;;; Profile the named function, which should exist and not be profiled 256;;; already. 257(defun profile-1-unprofiled-fun (name) 258 (let ((encapsulated-fun (fdefinition name))) 259 (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun) 260 (profile-encapsulation-lambdas) 261 (without-package-locks 262 (encapsulate name 'profile encapsulation-fun)) 263 (setf (gethash name *profiled-fun-name->info*) 264 (make-profile-info :name name 265 :encapsulated-fun encapsulated-fun 266 :encapsulation-fun encapsulation-fun 267 :read-stats-fun read-stats-fun 268 :clear-stats-fun clear-stats-fun)) 269 (values)))) 270 271;;; Profile the named function. If already profiled, unprofile first. 272(defun profile-1-fun (name) 273 (cond ((fboundp name) 274 (when (gethash name *profiled-fun-name->info*) 275 (warn "~S is already profiled, so unprofiling it first." name) 276 (unprofile-1-fun name)) 277 (profile-1-unprofiled-fun name)) 278 (t 279 (warn "ignoring undefined function ~S" name))) 280 (values)) 281 282;;; Unprofile the named function, if it is profiled. 283(defun unprofile-1-fun (name) 284 (let ((pinfo (gethash name *profiled-fun-name->info*))) 285 (cond (pinfo 286 (remhash name *profiled-fun-name->info*) 287 (without-package-locks 288 (unencapsulate name 'profile))) 289 (t 290 (warn "~S is not a profiled function." name)))) 291 (values)) 292 293(defmacro profile (&rest names) 294 #+sb-doc 295 "PROFILE Name* 296 297 If no names are supplied, return the list of profiled functions. 298 299 If names are supplied, wrap profiling code around the named functions. 300 As in TRACE, the names are not evaluated. A symbol names a function. 301 A string names all the functions named by symbols in the named 302 package. If a function is already profiled, then unprofile and 303 reprofile (useful to notice function redefinition.) If a name is 304 undefined, then we give a warning and ignore it. See also 305 UNPROFILE, REPORT and RESET." 306 (if (null names) 307 `(loop for k being each hash-key in *profiled-fun-name->info* 308 collecting k) 309 `(mapc-on-named-funs #'profile-1-fun ',names))) 310 311(defmacro unprofile (&rest names) 312 #+sb-doc 313 "Unwrap any profiling code around the named functions, or if no names 314 are given, unprofile all profiled functions. A symbol names 315 a function. A string names all the functions named by symbols in the 316 named package. NAMES defaults to the list of names of all currently 317 profiled functions." 318 (if names 319 `(mapc-on-named-funs #'unprofile-1-fun ',names) 320 `(unprofile-all))) 321 322(defun unprofile-all () 323 (dohash ((name profile-info) *profiled-fun-name->info* 324 :locked t) 325 (declare (ignore profile-info)) 326 (unprofile-1-fun name))) 327 328(defun reset () 329 #+sb-doc 330 "Reset the counters for all profiled functions." 331 (dohash ((name profile-info) *profiled-fun-name->info* :locked t) 332 (declare (ignore name)) 333 (funcall (profile-info-clear-stats-fun profile-info)))) 334 335;;;; reporting results 336 337(defstruct (time-info (:copier nil)) 338 name 339 calls 340 seconds 341 consing 342 gc-run-time) 343 344;;; Return our best guess for the run time in a function, subtracting 345;;; out factors for profiling overhead. We subtract out the internal 346;;; overhead for each call to this function, since the internal 347;;; overhead is the part of the profiling overhead for a function that 348;;; is charged to that function. 349;;; 350;;; We also subtract out a factor for each call to a profiled function 351;;; within this profiled function. This factor is the total profiling 352;;; overhead *minus the internal overhead*. We don't subtract out the 353;;; internal overhead, since it was already subtracted when the nested 354;;; profiled functions subtracted their running time from the time for 355;;; the enclosing function. 356(defun compensate-time (calls ticks profile) 357 (let ((raw-compensated 358 (- (/ (float ticks) (float +ticks-per-second+)) 359 (* (overhead-internal *overhead*) (float calls)) 360 (* (- (overhead-total *overhead*) 361 (overhead-internal *overhead*)) 362 (float profile))))) 363 (max raw-compensated 0.0))) 364 365(defun report (&key limit (print-no-call-list t)) 366 #+sb-doc 367 "Report results from profiling. The results are approximately 368adjusted for profiling overhead. The compensation may be rather 369inaccurate when bignums are involved in runtime calculation, as in a 370very-long-running Lisp process. 371 372If LIMIT is set to an integer, only the top LIMIT results are 373reported. If PRINT-NO-CALL-LIST is T (the default) then a list of 374uncalled profiled functions are listed." 375 (unless (boundp '*overhead*) 376 (setf *overhead* 377 (compute-overhead))) 378 (let ((time-info-list ()) 379 (no-call-name-list ())) 380 (dohash ((name pinfo) *profiled-fun-name->info* :locked t) 381 (multiple-value-bind (calls ticks consing profile gc-run-time) 382 (funcall (profile-info-read-stats-fun pinfo)) 383 (if (zerop calls) 384 (push name no-call-name-list) 385 (push (make-time-info :name name 386 :calls calls 387 :seconds (compensate-time calls 388 ticks 389 profile) 390 :consing consing 391 :gc-run-time gc-run-time) 392 time-info-list)))) 393 394 (let ((times 395 (sort time-info-list 396 #'>= 397 :key #'time-info-seconds))) 398 (print-profile-table 399 (if (and limit (> (length times) limit)) 400 (subseq times 0 limit) 401 times))) 402 403 (when (and print-no-call-list no-call-name-list) 404 (format *trace-output* 405 "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" 406 (sort no-call-name-list #'string< 407 :key (lambda (name) 408 (symbol-name (fun-name-block-name name)))))) 409 410 (values))) 411 412 413(defun print-profile-table (time-info-list) 414 (let ((total-seconds 0.0) 415 (total-consed 0) 416 (total-calls 0) 417 (total-gc-run-time 0) 418 (seconds-width (length "seconds")) 419 (consed-width (length "consed")) 420 (calls-width (length "calls")) 421 (sec/call-width 10) 422 (gc-run-time-width (length "gc")) 423 (name-width 6)) 424 (dolist (time-info time-info-list) 425 (incf total-seconds (time-info-seconds time-info)) 426 (incf total-consed (time-info-consing time-info)) 427 (incf total-calls (time-info-calls time-info)) 428 (incf total-gc-run-time (time-info-gc-run-time time-info))) 429 (setf seconds-width (max (length (format nil "~10,3F" total-seconds)) 430 seconds-width) 431 calls-width (max (length (format nil "~:D" total-calls)) 432 calls-width) 433 consed-width (max (length (format nil "~:D" total-consed)) 434 consed-width) 435 gc-run-time-width (max (length (format nil "~10,3F" (/ total-gc-run-time internal-time-units-per-second))) 436 gc-run-time-width)) 437 438 (flet ((dashes () 439 (dotimes (i (+ seconds-width consed-width calls-width 440 sec/call-width name-width 441 (* 5 3))) 442 (write-char #\- *trace-output*)) 443 (terpri *trace-output*))) 444 (format *trace-output* "~&~@{ ~v:@<~A~>~^|~}~%" 445 seconds-width "seconds" 446 (1+ gc-run-time-width) "gc" 447 (1+ consed-width) "consed" 448 (1+ calls-width) "calls" 449 (1+ sec/call-width) "sec/call" 450 (1+ name-width) "name") 451 452 (dashes) 453 454 (dolist (time-info time-info-list) 455 (format *trace-output* "~v,3F | ~v,3F | ~v:D | ~v:D | ~10,6F | ~S~%" 456 seconds-width (time-info-seconds time-info) 457 gc-run-time-width (/ (time-info-gc-run-time time-info) internal-time-units-per-second) 458 consed-width (time-info-consing time-info) 459 calls-width (time-info-calls time-info) 460 (/ (time-info-seconds time-info) 461 (float (time-info-calls time-info))) 462 (time-info-name time-info))) 463 464 (dashes) 465 466 (format *trace-output* "~v,3F | ~v,3F | ~v:D | ~v:D | | Total~%" 467 seconds-width total-seconds 468 gc-run-time-width (/ total-gc-run-time internal-time-units-per-second) 469 consed-width total-consed 470 calls-width total-calls) 471 472 (format *trace-output* 473 "~%estimated total profiling overhead: ~4,2F seconds~%" 474 (* (overhead-total *overhead*) (float total-calls))) 475 (format *trace-output* 476 "~&overhead estimation parameters:~% ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%" 477 (overhead-call *overhead*) 478 (overhead-total *overhead*) 479 (overhead-internal *overhead*))))) 480 481 482;;;; overhead estimation 483 484;;; We average the timing overhead over this many iterations. 485;;; 486;;; (This is a variable, not a constant, so that it can be set in 487;;; .sbclrc if desired. Right now, that's an unsupported extension 488;;; that I (WHN) use for my own experimentation, but it might 489;;; become supported someday. Comments?) 490(declaim (type unsigned-byte *timer-overhead-iterations*)) 491(defparameter *timer-overhead-iterations* 492 500000) 493 494;;; a dummy function that we profile to find profiling overhead 495(declaim (notinline compute-overhead-aux)) 496(defun compute-overhead-aux (x) 497 (declare (ignore x))) 498 499;;; Return a newly computed OVERHEAD object. 500(defun compute-overhead () 501 (format *debug-io* "~&measuring PROFILE overhead..") 502 (flet ((frob () 503 (let ((start (get-internal-ticks)) 504 (fun (symbol-function 'compute-overhead-aux))) 505 (declare (type function fun)) 506 (dotimes (i *timer-overhead-iterations*) 507 (funcall fun fun)) 508 (/ (float (- (get-internal-ticks) start)) 509 (float +ticks-per-second+) 510 (float *timer-overhead-iterations*))))) 511 (let (;; Measure unprofiled calls to estimate call overhead. 512 (call-overhead (frob)) 513 total-overhead 514 internal-overhead) 515 ;; Measure profiled calls to estimate profiling overhead. 516 (unwind-protect 517 (progn 518 (profile compute-overhead-aux) 519 (setf total-overhead 520 (- (frob) call-overhead))) 521 (let* ((pinfo (gethash 'compute-overhead-aux 522 *profiled-fun-name->info*)) 523 (read-stats-fun (profile-info-read-stats-fun pinfo)) 524 (time (nth-value 1 (funcall read-stats-fun)))) 525 (setf internal-overhead 526 (/ (float time) 527 (float +ticks-per-second+) 528 (float *timer-overhead-iterations*)))) 529 (unprofile compute-overhead-aux)) 530 (prog1 531 (make-overhead :call call-overhead 532 :total total-overhead 533 :internal internal-overhead) 534 (format *debug-io* "done~%"))))) 535 536;;; It would be bad to compute *OVERHEAD*, save it into a _core file, 537;;; then load the old *OVERHEAD* value from the _core file into a 538;;; different machine running at a different speed. We avoid this by 539;;; erasing *CALL-OVERHEAD* whenever we save a _core file. 540(defun profile-deinit () 541 (without-package-locks 542 (makunbound '*overhead*))) 543