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")
12 ;;;; reading internal run time with high resolution and low overhead
14 ;;; FIXME: It might make sense to replace this with something
15 ;;; with finer resolution, e.g. milliseconds or microseconds.
17 (defconstant +ticks-per-second+ internal-time-units-per-second)
19 (declaim (inline get-internal-ticks))
20 (defun get-internal-ticks () (get-internal-run-time))
24 ;;; a PCOUNTER is used to represent an integer quantity which can grow
25 ;;; bigger than a fixnum, but typically does so, if at all, in many
26 ;;; small steps, where we don't want to cons on every step. (Total
27 ;;; system consing, time spent in a profiled function, and bytes
28 ;;; consed in a profiled function are all examples of such
30 (defstruct (pcounter (:copier nil))
31 (integer 0 :type integer)
32 (fixnum 0 :type fixnum))
34 (declaim (ftype (function (pcounter integer) pcounter) incf-pcounter))
35 (declaim (inline incf-pcounter))
36 (defun incf-pcounter (pcounter delta)
37 (let ((sum (+ (pcounter-fixnum pcounter) delta)))
38 (cond ((typep sum 'fixnum)
39 (setf (pcounter-fixnum pcounter) sum))
41 (incf (pcounter-integer pcounter) sum)
42 (setf (pcounter-fixnum pcounter) 0))))
45 (declaim (ftype (function (pcounter) integer) pcounter->integer))
46 (declaim (inline pcounter->integer))
47 (defun pcounter->integer (pcounter)
48 (+ (pcounter-integer pcounter)
49 (pcounter-fixnum pcounter)))
51 ;;;; operations on (OR PCOUNTER FIXNUM)
53 ;;;; When we don't want to cons a PCOUNTER unless we're forced to, we
54 ;;;; start with a FIXNUM counter and only create a PCOUNTER if the
55 ;;;; FIXNUM overflows.
57 (declaim (ftype (function ((or pcounter fixnum) integer) (or pcounter fixnum)) %incf-pcounter-or-fixnum))
58 (declaim (inline %incf-pcounter-or-fixnum))
59 (defun %incf-pcounter-or-fixnum (x delta)
62 (let ((sum (+ x delta)))
63 (if (typep sum 'fixnum)
65 (make-pcounter :integer sum))))
67 (incf-pcounter x delta))))
69 (define-modify-macro incf-pcounter-or-fixnum (delta) %incf-pcounter-or-fixnum)
71 ;;; Trade off space for execution time by handling the common fast
72 ;;; (TYPEP DELTA 'FIXNUM) case inline and only calling generic
73 ;;; arithmetic as a last resort.
74 (defmacro fastbig-incf-pcounter-or-fixnum (x delta)
75 (once-only ((delta delta))
77 (fixnum (incf-pcounter-or-fixnum ,x ,delta))
78 (integer (incf-pcounter-or-fixnum ,x ,delta)))))
80 (declaim (ftype (function ((or pcounter fixnum)) integer) pcounter-or-fixnum->integer))
81 (declaim (maybe-inline pcounter-or-fixnum->integer))
82 (defun pcounter-or-fixnum->integer (x)
85 (pcounter (pcounter->integer x))))
87 ;;;; implementation-dependent interfaces
90 ;;; To avoid unnecessary consing in the "encapsulation" code, we want
91 ;;; find out the number of required arguments, and use &REST to
92 ;;; capture only non-required arguments. This function returns (VALUES
93 ;;; MIN-ARGS OPTIONALS-P), where MIN-ARGS is the number of required
94 ;;; arguments and OPTIONALS-P is true iff there are any non-required
95 ;;; arguments (such as &OPTIONAL, &REST, or &KEY).
96 (declaim (ftype (function ((or symbol cons)) (values fixnum t)) fun-signature))
97 (defun fun-signature (name)
98 (let ((type (info :function :type name)))
99 (cond ((not (function-type-p type))
102 (values (length (function-type-required type))
103 (or (function-type-optional type)
104 (function-type-keyp type)
105 (function-type-rest type)))))))
108 ;;;; global data structures
110 ;;; We associate a PROFILE-INFO structure with each profiled function
111 ;;; name. This holds the functions that we call to manipulate the
112 ;;; closure which implements the encapsulation.
113 (defvar *profiled-function-name->info* (make-hash-table))
114 (defstruct profile-info
115 (name (required-argument) :read-only t)
116 (encapsulated-fun (required-argument) :type function :read-only t)
117 (encapsulation-fun (required-argument) :type function :read-only t)
118 (read-stats-fun (required-argument) :type function :read-only t)
119 (clear-stats-fun (required-argument) :type function :read-only t))
121 ;;; These variables are used to subtract out the time and consing for
122 ;;; recursive and other dynamically nested profiled calls. The total
123 ;;; resource consumed for each nested call is added into the
124 ;;; appropriate variable. When the outer function returns, these
125 ;;; amounts are subtracted from the total.
126 (defvar *enclosed-ticks* 0)
127 (defvar *enclosed-consing* 0)
128 (declaim (type (or pcounter fixnum) *enclosed-ticks* *enclosed-consing*))
130 ;;; This variable is also used to subtract out time for nested
131 ;;; profiled calls. The time inside the profile wrapper call --
132 ;;; between its two calls to GET-INTERNAL-TICKS -- is accounted
133 ;;; for by the *ENCLOSED-TIME* variable. However, there's also extra
134 ;;; overhead involved, before we get to the first call to
135 ;;; GET-INTERNAL-TICKS, and after we get to the second call. By
136 ;;; keeping track of the count of enclosed profiled calls, we can try
137 ;;; to compensate for that.
138 (defvar *enclosed-profiles* 0)
139 (declaim (type (or pcounter fixnum) *enclosed-profiles*))
141 ;;; the components of profiling overhead
143 ;; the number of ticks a bare function call takes. This is
144 ;; factored into the other overheads, but not used for itself.
145 (call (required-argument) :type single-float :read-only t)
146 ;; the number of ticks that will be charged to a profiled
147 ;; function due to the profiling code
148 (internal (required-argument) :type single-float :read-only t)
149 ;; the number of ticks of overhead for profiling that a single
150 ;; profiled call adds to the total runtime for the program
151 (total (required-argument) :type single-float :read-only t))
153 (declaim (type overhead *overhead*))
155 ;;;; profile encapsulations
157 ;;; Trade off space for time by handling the usual all-FIXNUM cases
159 (defmacro fastbig- (x y)
160 (once-only ((x x) (y y))
161 `(if (and (typep ,x 'fixnum)
165 (defmacro fastbig-1+ (x)
167 `(if (typep ,x 'index)
171 ;;; Return a collection of closures over the same lexical context,
172 ;;; (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN).
174 ;;; ENCAPSULATION-FUN is a plug-in replacement for ENCAPSULATED-FUN,
175 ;;; which updates statistics whenver it's called.
177 ;;; READ-STATS-FUN returns the statistics:
178 ;;; (VALUES COUNT TIME CONSING PROFILE).
179 ;;; COUNT is the count of calls to ENCAPSULATION-FUN. TICKS is
180 ;;; the total number of ticks spent in ENCAPSULATED-FUN.
181 ;;; CONSING is the total consing of ENCAPSULATION-FUN. PROFILE is the
182 ;;; number of calls to the profiled function, stored for the purposes
183 ;;; of trying to estimate that part of profiling overhead which occurs
184 ;;; outside the interval between the profile wrapper function's timer
187 ;;; CLEAR-STATS-FUN clears the statistics.
189 ;;; (The reason for implementing this as coupled closures, with the
190 ;;; counts built into the lexical environment, is that we hope this
191 ;;; will minimize profiling overhead.)
192 (defun profile-encapsulation-lambdas (encapsulated-fun)
193 (declare (type function encapsulated-fun))
194 (declare (optimize speed safety))
199 (declare (type (or pcounter fixnum) count ticks consing profiles))
202 (lambda (sb-c:&more arg-context arg-count)
203 #+nil (declare (optimize (speed 3) (safety 0))) ; FIXME: remove #+NIL?
204 (fastbig-incf-pcounter-or-fixnum count 1)
207 (inner-enclosed-profiles 0))
208 (declare (type unsigned-byte dticks dconsing))
209 (declare (type unsigned-byte inner-enclosed-profiles))
210 (multiple-value-prog1
211 (let ((start-ticks (get-internal-ticks))
212 ;; KLUDGE: We add (THE UNSIGNED-BYTE ..) wrappers
213 ;; around GET-BYTES-CONSED because as of
214 ;; sbcl-0.6.4, at the time that the FTYPE of
215 ;; GET-BYTES-CONSED is DECLAIMed, the
216 ;; cross-compiler's type system isn't mature enough
217 ;; to do anything about it. -- WHN 20000503
218 (start-consing (the unsigned-byte (get-bytes-consed)))
220 (*enclosed-consing* 0)
221 (*enclosed-profiles* 0))
222 (declare (inline pcounter-or-fixnum->integer))
223 (multiple-value-prog1
224 (multiple-value-call encapsulated-fun
225 (sb-c:%more-arg-values arg-context
228 (setf dticks (fastbig- (get-internal-ticks) start-ticks)
229 dconsing (fastbig- (the unsigned-byte
232 (setf inner-enclosed-profiles
233 (pcounter-or-fixnum->integer *enclosed-profiles*))
234 (fastbig-incf-pcounter-or-fixnum ticks (fastbig-
237 (fastbig-incf-pcounter-or-fixnum consing
241 (fastbig-incf-pcounter-or-fixnum profiles
242 inner-enclosed-profiles)))
243 (fastbig-incf-pcounter-or-fixnum *enclosed-ticks* dticks)
244 (fastbig-incf-pcounter-or-fixnum *enclosed-consing* dconsing)
245 (fastbig-incf-pcounter-or-fixnum *enclosed-profiles*
247 inner-enclosed-profiles)))))
250 (values (pcounter-or-fixnum->integer count)
251 (pcounter-or-fixnum->integer ticks)
252 (pcounter-or-fixnum->integer consing)
253 (pcounter-or-fixnum->integer profiles)))
263 ;;; A symbol or (SETF FOO) list names a function, a string names all
264 ;;; the functions named by symbols in the named package.
265 (defun mapc-on-named-functions (function names)
268 (symbol (funcall function name))
270 ;; We call this just for the side effect of checking that
271 ;; NAME is a legal function name:
272 (function-name-block-name name)
273 ;; Then we map onto it.
274 (funcall function name))
275 (string (let ((package (find-undeleted-package-or-lose name)))
276 (do-symbols (symbol package)
277 (when (eq (symbol-package symbol) package)
278 (when (fboundp symbol)
279 (funcall function symbol))
280 (let ((setf-name `(setf ,symbol)))
281 (when (fboundp setf-name)
282 (funcall function setf-name)))))))))
285 ;;; Profile the named function, which should exist and not be profiled
287 (defun profile-1-unprofiled-function (name)
288 (let ((encapsulated-fun (fdefinition name)))
289 (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
290 (profile-encapsulation-lambdas encapsulated-fun)
291 (setf (fdefinition name)
293 (setf (gethash name *profiled-function-name->info*)
294 (make-profile-info :name name
295 :encapsulated-fun encapsulated-fun
296 :encapsulation-fun encapsulation-fun
297 :read-stats-fun read-stats-fun
298 :clear-stats-fun clear-stats-fun))
301 ;;; Profile the named function. If already profiled, unprofile first.
302 (defun profile-1-function (name)
303 (cond ((fboundp name)
304 (when (gethash name *profiled-function-name->info*)
305 (warn "~S is already profiled, so unprofiling it first." name)
306 (unprofile-1-function name))
307 (profile-1-unprofiled-function name))
309 (warn "ignoring undefined function ~S" name)))
312 ;;; Unprofile the named function, if it is profiled.
313 (defun unprofile-1-function (name)
314 (let ((pinfo (gethash name *profiled-function-name->info*)))
316 (remhash name *profiled-function-name->info*)
317 (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
318 (setf (fdefinition name) (profile-info-encapsulated-fun pinfo))
319 (warn "preserving current definition of redefined function ~S"
322 (warn "~S is not a profiled function." name))))
325 (defmacro profile (&rest names)
329 If no names are supplied, return the list of profiled functions.
331 If names are supplied, wrap profiling code around the named functions.
332 As in TRACE, the names are not evaluated. A symbol names a function.
333 A string names all the functions named by symbols in the named
334 package. If a function is already profiled, then unprofile and
335 reprofile (useful to notice function redefinition.) If a name is
336 undefined, then we give a warning and ignore it. See also
337 UNPROFILE, REPORT and RESET."
339 `(loop for k being each hash-key in *profiled-function-name->info*
341 `(mapc-on-named-functions #'profile-1-function ',names)))
343 (defmacro unprofile (&rest names)
345 "Unwrap any profiling code around the named functions, or if no names
346 are given, unprofile all profiled functions. A symbol names
347 a function. A string names all the functions named by symbols in the
348 named package. NAMES defaults to the list of names of all currently
351 `(mapc-on-named-functions #'unprofile-1-function ',names)
354 (defun unprofile-all ()
355 (dohash (name profile-info *profiled-function-name->info*)
356 (declare (ignore profile-info))
357 (unprofile-1-function name)))
360 "Reset the counters for all profiled functions."
361 (dohash (name profile-info *profiled-function-name->info*)
362 (declare (ignore name))
363 (funcall (profile-info-clear-stats-fun profile-info))))
365 ;;;; reporting results
373 ;;; Return our best guess for the run time in a function, subtracting
374 ;;; out factors for profiling overhead. We subtract out the internal
375 ;;; overhead for each call to this function, since the internal
376 ;;; overhead is the part of the profiling overhead for a function that
377 ;;; is charged to that function.
379 ;;; We also subtract out a factor for each call to a profiled function
380 ;;; within this profiled function. This factor is the total profiling
381 ;;; overhead *minus the internal overhead*. We don't subtract out the
382 ;;; internal overhead, since it was already subtracted when the nested
383 ;;; profiled functions subtracted their running time from the time for
384 ;;; the enclosing function.
385 (defun compensate-time (calls ticks profile)
386 (let ((raw-compensated
387 (- (/ (float ticks) (float +ticks-per-second+))
388 (* (overhead-internal *overhead*) (float calls))
389 (* (- (overhead-total *overhead*)
390 (overhead-internal *overhead*))
392 (max raw-compensated 0.0)))
395 "Report results from profiling. The results are
396 approximately adjusted for profiling overhead, but when RAW is true
397 the unadjusted results are reported. The compensation may be somewhat
398 inaccurate when bignums are involved in runtime calculation, as in
399 a very-long-running Lisp process."
400 (declare (optimize (speed 0)))
401 (unless (boundp '*overhead*)
404 (let ((time-info-list ())
405 (no-call-name-list ()))
406 (dohash (name pinfo *profiled-function-name->info*)
407 (unless (eq (fdefinition name)
408 (profile-info-encapsulation-fun pinfo))
409 (warn "Function ~S has been redefined, so times may be inaccurate.~@
410 PROFILE it again to record calls to the new definition."
412 (multiple-value-bind (calls ticks consing profile)
413 (funcall (profile-info-read-stats-fun pinfo))
415 (push name no-call-name-list)
416 (push (make-time-info :name name
418 :seconds (compensate-time calls
427 :key #'time-info-seconds))
429 (format *trace-output*
430 "~& seconds | consed | calls | sec/call | name~@
431 ------------------------------------------------------~%")
433 (let ((total-time 0.0)
436 (dolist (time-info time-info-list)
437 (incf total-time (time-info-seconds time-info))
438 (incf total-calls (time-info-calls time-info))
439 (incf total-consed (time-info-consing time-info))
440 (format *trace-output*
441 "~10,3F | ~9:D | ~7:D | ~10,6F | ~S~%"
442 (time-info-seconds time-info)
443 (time-info-consing time-info)
444 (time-info-calls time-info)
445 (/ (time-info-seconds time-info)
446 (float (time-info-calls time-info)))
447 (time-info-name time-info)))
448 (format *trace-output*
449 "------------------------------------------------------~@
450 ~10,3F | ~9:D | ~7:D | | Total~%"
451 total-time total-consed total-calls)
452 (format *trace-output*
453 "~%estimated total profiling overhead: ~4,2F seconds~%"
454 (* (overhead-total *overhead*) (float total-calls)))
455 (format *trace-output*
456 "~&overhead estimation parameters:~% ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%"
457 (overhead-call *overhead*)
458 (overhead-total *overhead*)
459 (overhead-internal *overhead*)))
461 (when no-call-name-list
462 (format *trace-output*
463 "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
464 (sort no-call-name-list #'string<
466 (symbol-name (function-name-block-name name))))))
470 ;;;; overhead estimation
472 ;;; We average the timing overhead over this many iterations.
473 (defconstant +timer-overhead-iterations+ 50000)
475 ;;; a dummy function that we profile to find profiling overhead
476 (declaim (notinline compute-overhead-aux))
477 (defun compute-overhead-aux (x)
478 (declare (ignore x)))
480 ;;; Return a newly computed OVERHEAD object.
481 (defun compute-overhead ()
483 (let ((start (get-internal-ticks))
484 (fun (symbol-function 'compute-overhead-aux)))
485 (dotimes (i +timer-overhead-iterations+)
487 (/ (float (- (get-internal-ticks) start))
488 (float +ticks-per-second+)
489 (float +timer-overhead-iterations+)))))
490 (let (;; Measure unprofiled calls to estimate call overhead.
491 (call-overhead (frob))
494 ;; Measure profiled calls to estimate profiling overhead.
497 (profile compute-overhead-aux)
499 (- (frob) call-overhead)))
500 (let* ((pinfo (gethash 'compute-overhead-aux
501 *profiled-function-name->info*))
502 (read-stats-fun (profile-info-read-stats-fun pinfo))
503 (time (nth-value 1 (funcall read-stats-fun))))
504 (setf internal-overhead
506 (float +ticks-per-second+)
507 (float +timer-overhead-iterations+))))
508 (unprofile compute-overhead-aux))
509 (make-overhead :call call-overhead
510 :total total-overhead
511 :internal internal-overhead))))
513 ;;; It would be bad to compute *OVERHEAD*, save it into a .core file,
514 ;;; then load old *OVERHEAD* value from the .core file into a
515 ;;; different machine running at a different speed. We avoid this by
516 ;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
518 (makunbound '*overhead*))
519 *before-save-initializations*)