1 ;;;; This software is part of the SBCL system. See the README file for
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.
10 (in-package "SB-PROFILE") ; (SB-, not SB!, since we're built in warm load.)
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.
18 (defconstant +most-positive-word+ (1- (expt 2 sb-vm:n-word-bits)))
20 (declaim (inline make-counter))
21 (defstruct (counter (:constructor make-counter) (:copier nil))
22 (word 0 :type sb-vm:word)
23 (overflow 0 :type unsigned-byte))
25 (defun incf-counter (counter delta)
26 ;; When running multi-threaded we can easily get negative numbers for the
27 ;; cons-counter. Don't count them at all.
29 (labels ((%incf-overflow (&optional (n 1))
30 ;; Overflow-counter can run into bignums... so we need to loop
31 ;; around CAS till the increment succeeds.
32 (loop for old = (counter-overflow counter)
33 until (eq old (compare-and-swap (counter-overflow counter)
36 ;; Increment the word-sized counter. If it overflows, record the
38 (let ((prev (atomic-incf (counter-word counter) d)))
39 (when (< (logand +most-positive-word+ (+ prev d)) prev)
41 (atomic-incf (counter-word counter))))))
42 ;; DELTA can potentially be a bignum -- cut it down to word-size.
43 (unless (typep delta 'sb-vm:word)
44 (multiple-value-bind (n r) (truncate delta +most-positive-word+)
47 ;; ATOMIC-INCF can at most handle SIGNED-WORD: if DELTA doesn't fit that,
49 (if (typep delta 'sb-vm:signed-word)
51 ;; ...and if delta is still too big, split it into four parts: they
52 ;; are guaranteed to fit into a signed word.
53 (multiple-value-bind (n r) (truncate delta 2)
59 (defun counter-count (counter)
60 (+ (counter-word counter)
61 (* (counter-overflow counter)
62 +most-positive-word+)))
64 ;;;; High resolution timer
66 ;;; FIXME: High resolution this is not. Build a microsecond-accuracy version
67 ;;; on top of unix-getrusage, maybe.
69 (defconstant +ticks-per-second+ internal-time-units-per-second)
71 (declaim (inline get-internal-ticks))
72 (defun get-internal-ticks ()
73 (get-internal-run-time))
75 ;;;; global data structures
77 ;;; We associate a PROFILE-INFO structure with each profiled function
78 ;;; name. This holds the functions that we call to manipulate the
79 ;;; closure which implements the encapsulation.
80 (defvar *profiled-fun-name->info*
82 ;; EQL testing isn't good enough for generalized function names
86 (defstruct (profile-info (:copier nil))
87 (name (missing-arg) :read-only t)
88 (encapsulated-fun (missing-arg) :type function :read-only t)
89 (encapsulation-fun (missing-arg) :type function :read-only t)
90 (read-stats-fun (missing-arg) :type function :read-only t)
91 (clear-stats-fun (missing-arg) :type function :read-only t))
93 ;;; These variables are used to subtract out the time and consing for
94 ;;; recursive and other dynamically nested profiled calls. The total
95 ;;; resource consumed for each nested call is added into the
96 ;;; appropriate variable. When the outer function returns, these
97 ;;; amounts are subtracted from the total.
98 (declaim (counter *enclosed-ticks* *enclosed-consing*))
99 (defvar *enclosed-ticks*)
100 (defvar *enclosed-consing*)
102 ;;; This variable is also used to subtract out time for nested
103 ;;; profiled calls. The time inside the profile wrapper call --
104 ;;; between its two calls to GET-INTERNAL-TICKS -- is accounted
105 ;;; for by the *ENCLOSED-TIME* variable. However, there's also extra
106 ;;; overhead involved, before we get to the first call to
107 ;;; GET-INTERNAL-TICKS, and after we get to the second call. By
108 ;;; keeping track of the count of enclosed profiled calls, we can try
109 ;;; to compensate for that.
110 (declaim (counter *enclosed-profiles*))
111 (defvar *enclosed-profiles*)
113 (declaim (counter *enclosed-gc-run-time*))
114 (defvar *enclosed-gc-run-time*)
116 ;;; the encapsulated function we're currently computing profiling data
117 ;;; for, recorded so that we can detect the problem of
118 ;;; PROFILE-computing machinery calling a function which has itself
120 (defvar *computing-profiling-data-for*)
122 ;;; the components of profiling overhead
123 (defstruct (overhead (:copier nil))
124 ;; the number of ticks a bare function call takes. This is
125 ;; factored into the other overheads, but not used for itself.
126 (call (missing-arg) :type single-float :read-only t)
127 ;; the number of ticks that will be charged to a profiled
128 ;; function due to the profiling code
129 (internal (missing-arg) :type single-float :read-only t)
130 ;; the number of ticks of overhead for profiling that a single
131 ;; profiled call adds to the total runtime for the program
132 (total (missing-arg) :type single-float :read-only t))
134 (declaim (type overhead *overhead*))
135 (makunbound '*overhead*) ; in case we reload this file when tweaking
137 ;;;; profile encapsulations
139 ;;; Return a collection of closures over the same lexical context,
140 ;;; (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN).
142 ;;; ENCAPSULATION-FUN is a plug-in replacement for ENCAPSULATED-FUN,
143 ;;; which updates statistics whenever it's called.
145 ;;; READ-STATS-FUN returns the statistics:
146 ;;; (VALUES COUNT TIME CONSING PROFILE).
147 ;;; COUNT is the count of calls to ENCAPSULATION-FUN. TICKS is
148 ;;; the total number of ticks spent in ENCAPSULATED-FUN.
149 ;;; CONSING is the total consing of ENCAPSULATION-FUN. PROFILE is the
150 ;;; number of calls to the profiled function, stored for the purposes
151 ;;; of trying to estimate that part of profiling overhead which occurs
152 ;;; outside the interval between the profile wrapper function's timer
155 ;;; CLEAR-STATS-FUN clears the statistics.
157 ;;; (The reason for implementing this as coupled closures, with the
158 ;;; counts built into the lexical environment, is that we hope this
159 ;;; will minimize profiling overhead.)
160 (defun profile-encapsulation-lambdas (encapsulated-fun)
161 (declare (type function encapsulated-fun))
162 (let* ((count (make-counter))
163 (ticks (make-counter))
164 (consing (make-counter))
165 (profiles (make-counter))
166 (gc-run-time (make-counter)))
167 (declare (counter count ticks consing profiles gc-run-time))
170 (lambda (&more arg-context arg-count)
171 (declare (optimize speed safety))
172 ;; Make sure that we're not recursing infinitely.
173 (when (boundp '*computing-profiling-data-for*)
174 (unprofile-all) ; to avoid further recursion
175 (error "~@<When computing profiling data for ~S, the profiled ~
176 function ~S was called. To get out of this infinite recursion, all ~
177 functions have been unprofiled. (Since the profiling system evidently ~
178 uses ~S in its computations, it looks as though it's a bad idea to ~
180 *computing-profiling-data-for* encapsulated-fun
182 (incf-counter count 1)
185 (inner-enclosed-profiles 0)
187 (declare (truly-dynamic-extent dticks dconsing inner-enclosed-profiles))
189 (let* ((start-ticks (get-internal-ticks))
190 (start-gc-run-time *gc-run-time*)
191 (*enclosed-ticks* (make-counter))
192 (*enclosed-consing* (make-counter))
193 (*enclosed-profiles* (make-counter))
194 (nbf0 *n-bytes-freed-or-purified*)
195 (dynamic-usage-0 (sb-kernel:dynamic-usage))
196 (*enclosed-gc-run-time* (make-counter)))
197 (declare (dynamic-extent *enclosed-ticks* *enclosed-consing* *enclosed-profiles* *enclosed-gc-run-time*))
199 (multiple-value-call encapsulated-fun
200 (sb-c:%more-arg-values arg-context
203 (let ((*computing-profiling-data-for* encapsulated-fun)
204 (dynamic-usage-1 (sb-kernel:dynamic-usage)))
205 (setf dticks (- (get-internal-ticks) start-ticks)
206 dconsing (if (eql *n-bytes-freed-or-purified* nbf0)
207 ;; common special case where we can avoid
209 (- dynamic-usage-1 dynamic-usage-0)
211 (- (get-bytes-consed) nbf0 dynamic-usage-0))
212 inner-enclosed-profiles (counter-count *enclosed-profiles*)
213 dgc-run-time (- *gc-run-time* start-gc-run-time))
214 (incf-counter ticks (- dticks (counter-count *enclosed-ticks*)))
215 (incf-counter gc-run-time (- dgc-run-time (counter-count *enclosed-gc-run-time*)))
216 (incf-counter consing (- dconsing (counter-count *enclosed-consing*)))
217 (incf-counter profiles inner-enclosed-profiles))))
218 (when (boundp '*enclosed-ticks*)
219 (incf-counter *enclosed-ticks* dticks)
220 (incf-counter *enclosed-consing* dconsing)
221 (incf-counter *enclosed-profiles* (1+ inner-enclosed-profiles))
222 (incf-counter *enclosed-gc-run-time* dgc-run-time)))))
225 (values (counter-count count)
226 (counter-count ticks)
227 (counter-count consing)
228 (counter-count profiles)
229 (counter-count gc-run-time)))
232 (setf count (make-counter)
234 consing (make-counter)
235 profiles (make-counter)
236 gc-run-time (make-counter))))))
240 ;;; A symbol or (SETF FOO) list names a function, a string names all
241 ;;; the functions named by symbols in the named package.
242 (defun mapc-on-named-funs (function names)
245 (symbol (funcall function name))
247 (legal-fun-name-or-type-error name)
248 ;; Then we map onto it.
249 (funcall function name))
250 (string (let ((package (find-undeleted-package-or-lose name)))
251 (do-symbols (symbol package)
252 (when (eq (symbol-package symbol) package)
253 (when (and (fboundp symbol)
254 (not (macro-function symbol))
255 (not (special-operator-p symbol)))
256 (funcall function symbol))
257 (let ((setf-name `(setf ,symbol)))
258 (when (fboundp setf-name)
259 (funcall function setf-name)))))))))
262 ;;; Profile the named function, which should exist and not be profiled
264 (defun profile-1-unprofiled-fun (name)
265 (let ((encapsulated-fun (fdefinition name)))
266 (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
267 (profile-encapsulation-lambdas encapsulated-fun)
268 (without-package-locks
269 (setf (fdefinition name)
271 (setf (gethash name *profiled-fun-name->info*)
272 (make-profile-info :name name
273 :encapsulated-fun encapsulated-fun
274 :encapsulation-fun encapsulation-fun
275 :read-stats-fun read-stats-fun
276 :clear-stats-fun clear-stats-fun))
279 ;;; Profile the named function. If already profiled, unprofile first.
280 (defun profile-1-fun (name)
281 (cond ((fboundp name)
282 (when (gethash name *profiled-fun-name->info*)
283 (warn "~S is already profiled, so unprofiling it first." name)
284 (unprofile-1-fun name))
285 (profile-1-unprofiled-fun name))
287 (warn "ignoring undefined function ~S" name)))
290 ;;; Unprofile the named function, if it is profiled.
291 (defun unprofile-1-fun (name)
292 (let ((pinfo (gethash name *profiled-fun-name->info*)))
294 (remhash name *profiled-fun-name->info*)
295 (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
296 (without-package-locks
297 (setf (fdefinition name) (profile-info-encapsulated-fun pinfo)))
298 (warn "preserving current definition of redefined function ~S"
301 (warn "~S is not a profiled function." name))))
304 (defmacro profile (&rest names)
308 If no names are supplied, return the list of profiled functions.
310 If names are supplied, wrap profiling code around the named functions.
311 As in TRACE, the names are not evaluated. A symbol names a function.
312 A string names all the functions named by symbols in the named
313 package. If a function is already profiled, then unprofile and
314 reprofile (useful to notice function redefinition.) If a name is
315 undefined, then we give a warning and ignore it. See also
316 UNPROFILE, REPORT and RESET."
318 `(loop for k being each hash-key in *profiled-fun-name->info*
320 `(mapc-on-named-funs #'profile-1-fun ',names)))
322 (defmacro unprofile (&rest names)
324 "Unwrap any profiling code around the named functions, or if no names
325 are given, unprofile all profiled functions. A symbol names
326 a function. A string names all the functions named by symbols in the
327 named package. NAMES defaults to the list of names of all currently
330 `(mapc-on-named-funs #'unprofile-1-fun ',names)
333 (defun unprofile-all ()
334 (dohash ((name profile-info) *profiled-fun-name->info*
336 (declare (ignore profile-info))
337 (unprofile-1-fun name)))
340 "Reset the counters for all profiled functions."
341 (dohash ((name profile-info) *profiled-fun-name->info* :locked t)
342 (declare (ignore name))
343 (funcall (profile-info-clear-stats-fun profile-info))))
345 ;;;; reporting results
347 (defstruct (time-info (:copier nil))
354 ;;; Return our best guess for the run time in a function, subtracting
355 ;;; out factors for profiling overhead. We subtract out the internal
356 ;;; overhead for each call to this function, since the internal
357 ;;; overhead is the part of the profiling overhead for a function that
358 ;;; is charged to that function.
360 ;;; We also subtract out a factor for each call to a profiled function
361 ;;; within this profiled function. This factor is the total profiling
362 ;;; overhead *minus the internal overhead*. We don't subtract out the
363 ;;; internal overhead, since it was already subtracted when the nested
364 ;;; profiled functions subtracted their running time from the time for
365 ;;; the enclosing function.
366 (defun compensate-time (calls ticks profile)
367 (let ((raw-compensated
368 (- (/ (float ticks) (float +ticks-per-second+))
369 (* (overhead-internal *overhead*) (float calls))
370 (* (- (overhead-total *overhead*)
371 (overhead-internal *overhead*))
373 (max raw-compensated 0.0)))
376 "Report results from profiling. The results are approximately adjusted
377 for profiling overhead. The compensation may be rather inaccurate when
378 bignums are involved in runtime calculation, as in a very-long-running
380 (unless (boundp '*overhead*)
383 (let ((time-info-list ())
384 (no-call-name-list ()))
385 (dohash ((name pinfo) *profiled-fun-name->info* :locked t)
386 (unless (eq (fdefinition name)
387 (profile-info-encapsulation-fun pinfo))
388 (warn "Function ~S has been redefined, so times may be inaccurate.~@
389 PROFILE it again to record calls to the new definition."
391 (multiple-value-bind (calls ticks consing profile gc-run-time)
392 (funcall (profile-info-read-stats-fun pinfo))
394 (push name no-call-name-list)
395 (push (make-time-info :name name
397 :seconds (compensate-time calls
401 :gc-run-time gc-run-time)
407 :key #'time-info-seconds))
408 (print-profile-table time-info-list)
410 (when no-call-name-list
411 (format *trace-output*
412 "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
413 (sort no-call-name-list #'string<
415 (symbol-name (fun-name-block-name name))))))
420 (defun print-profile-table (time-info-list)
421 (let ((total-seconds 0.0)
424 (total-gc-run-time 0)
425 (seconds-width (length "seconds"))
426 (consed-width (length "consed"))
427 (calls-width (length "calls"))
429 (gc-run-time-width (length "gc"))
431 (dolist (time-info time-info-list)
432 (incf total-seconds (time-info-seconds time-info))
433 (incf total-consed (time-info-consing time-info))
434 (incf total-calls (time-info-calls time-info))
435 (incf total-gc-run-time (time-info-gc-run-time time-info)))
436 (setf seconds-width (max (length (format nil "~10,3F" total-seconds))
438 calls-width (max (length (format nil "~:D" total-calls))
440 consed-width (max (length (format nil "~:D" total-consed))
442 gc-run-time-width (max (length (format nil "~10,3F" (/ total-gc-run-time internal-time-units-per-second)))
446 (dotimes (i (+ seconds-width consed-width calls-width
447 sec/call-width name-width
449 (write-char #\- *trace-output*))
450 (terpri *trace-output*)))
451 (format *trace-output* "~&~@{ ~v:@<~A~>~^|~}~%"
452 seconds-width "seconds"
453 (1+ gc-run-time-width) "gc"
454 (1+ consed-width) "consed"
455 (1+ calls-width) "calls"
456 (1+ sec/call-width) "sec/call"
457 (1+ name-width) "name")
461 (dolist (time-info time-info-list)
462 (format *trace-output* "~v,3F | ~v,3F | ~v:D | ~v:D | ~10,6F | ~S~%"
463 seconds-width (time-info-seconds time-info)
464 gc-run-time-width (/ (time-info-gc-run-time time-info) internal-time-units-per-second)
465 consed-width (time-info-consing time-info)
466 calls-width (time-info-calls time-info)
467 (/ (time-info-seconds time-info)
468 (float (time-info-calls time-info)))
469 (time-info-name time-info)))
473 (format *trace-output* "~v,3F | ~v,3F | ~v:D | ~v:D | | Total~%"
474 seconds-width total-seconds
475 gc-run-time-width (/ total-gc-run-time internal-time-units-per-second)
476 consed-width total-consed
477 calls-width total-calls)
479 (format *trace-output*
480 "~%estimated total profiling overhead: ~4,2F seconds~%"
481 (* (overhead-total *overhead*) (float total-calls)))
482 (format *trace-output*
483 "~&overhead estimation parameters:~% ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%"
484 (overhead-call *overhead*)
485 (overhead-total *overhead*)
486 (overhead-internal *overhead*)))))
489 ;;;; overhead estimation
491 ;;; We average the timing overhead over this many iterations.
493 ;;; (This is a variable, not a constant, so that it can be set in
494 ;;; .sbclrc if desired. Right now, that's an unsupported extension
495 ;;; that I (WHN) use for my own experimentation, but it might
496 ;;; become supported someday. Comments?)
497 (declaim (type unsigned-byte *timer-overhead-iterations*))
498 (defparameter *timer-overhead-iterations*
501 ;;; a dummy function that we profile to find profiling overhead
502 (declaim (notinline compute-overhead-aux))
503 (defun compute-overhead-aux (x)
504 (declare (ignore x)))
506 ;;; Return a newly computed OVERHEAD object.
507 (defun compute-overhead ()
508 (format *debug-io* "~&measuring PROFILE overhead..")
510 (let ((start (get-internal-ticks))
511 (fun (symbol-function 'compute-overhead-aux)))
512 (declare (type function fun))
513 (dotimes (i *timer-overhead-iterations*)
515 (/ (float (- (get-internal-ticks) start))
516 (float +ticks-per-second+)
517 (float *timer-overhead-iterations*)))))
518 (let (;; Measure unprofiled calls to estimate call overhead.
519 (call-overhead (frob))
522 ;; Measure profiled calls to estimate profiling overhead.
525 (profile compute-overhead-aux)
527 (- (frob) call-overhead)))
528 (let* ((pinfo (gethash 'compute-overhead-aux
529 *profiled-fun-name->info*))
530 (read-stats-fun (profile-info-read-stats-fun pinfo))
531 (time (nth-value 1 (funcall read-stats-fun))))
532 (setf internal-overhead
534 (float +ticks-per-second+)
535 (float *timer-overhead-iterations*))))
536 (unprofile compute-overhead-aux))
538 (make-overhead :call call-overhead
539 :total total-overhead
540 :internal internal-overhead)
541 (format *debug-io* "done~%")))))
543 ;;; It would be bad to compute *OVERHEAD*, save it into a .core file,
544 ;;; then load the old *OVERHEAD* value from the .core file into a
545 ;;; different machine running at a different speed. We avoid this by
546 ;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
547 (defun profile-deinit ()
548 (without-package-locks
549 (makunbound '*overhead*)))