a381821f1fd398826d7cb8f3aa6431aaa24124d2
[sbcl.git] / src / code / profile.lisp
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 \f
12 ;;;; reading internal run time with high resolution and low overhead
13
14 ;;; FIXME: It might make sense to replace this with something
15 ;;; with finer resolution, e.g. milliseconds or microseconds.
16 ;;; For that matter, maybe we should boost the internal clock
17 ;;; up to something faster, like milliseconds.
18
19 (defconstant +ticks-per-second+ internal-time-units-per-second)
20
21 (declaim (inline get-internal-ticks))
22 (defun get-internal-ticks () (get-internal-run-time))
23 \f
24 ;;;; implementation-dependent interfaces
25
26 #|
27 ;;; To avoid unnecessary consing in the "encapsulation" code, we want
28 ;;; find out the number of required arguments, and use &REST to
29 ;;; capture only non-required arguments. This function returns (VALUES
30 ;;; MIN-ARGS OPTIONALS-P), where MIN-ARGS is the number of required
31 ;;; arguments and OPTIONALS-P is true iff there are any non-required
32 ;;; arguments (such as &OPTIONAL, &REST, or &KEY).
33 (declaim (ftype (function ((or symbol cons)) (values fixnum t)) fun-signature))
34 (defun fun-signature (name)
35   (let ((type (info :function :type name)))
36     (cond ((not (function-type-p type))
37            (values 0 t))
38           (t
39            (values (length (function-type-required type))
40                    (or (function-type-optional type)
41                        (function-type-keyp type)
42                        (function-type-rest type)))))))
43 |#
44 \f
45 ;;;; global data structures
46
47 ;;; We associate a PROFILE-INFO structure with each profiled function
48 ;;; name. This holds the functions that we call to manipulate the
49 ;;; closure which implements the encapsulation.
50 (defvar *profiled-function-name->info* (make-hash-table))
51 (defstruct (profile-info (:copier nil))
52   (name              (required-argument) :read-only t)
53   (encapsulated-fun  (required-argument) :type function :read-only t)
54   (encapsulation-fun (required-argument) :type function :read-only t)
55   (read-stats-fun    (required-argument) :type function :read-only t)
56   (clear-stats-fun   (required-argument) :type function :read-only t))
57
58 ;;; These variables are used to subtract out the time and consing for
59 ;;; recursive and other dynamically nested profiled calls. The total
60 ;;; resource consumed for each nested call is added into the
61 ;;; appropriate variable. When the outer function returns, these
62 ;;; amounts are subtracted from the total.
63 (defvar *enclosed-ticks* 0)
64 (defvar *enclosed-consing* 0)
65 (declaim (type (or pcounter fixnum) *enclosed-ticks* *enclosed-consing*))
66
67 ;;; This variable is also used to subtract out time for nested
68 ;;; profiled calls. The time inside the profile wrapper call --
69 ;;; between its two calls to GET-INTERNAL-TICKS -- is accounted
70 ;;; for by the *ENCLOSED-TIME* variable. However, there's also extra
71 ;;; overhead involved, before we get to the first call to
72 ;;; GET-INTERNAL-TICKS, and after we get to the second call. By
73 ;;; keeping track of the count of enclosed profiled calls, we can try
74 ;;; to compensate for that.
75 (defvar *enclosed-profiles* 0)
76 (declaim (type (or pcounter fixnum) *enclosed-profiles*))
77
78 ;;; the encapsulated function we're currently computing profiling data
79 ;;; for, recorded so that we can detect the problem of
80 ;;; PROFILE-computing machinery calling a function which has itself
81 ;;; been PROFILEd
82 (defvar *computing-profiling-data-for*)
83
84 ;;; the components of profiling overhead
85 (defstruct (overhead (:copier nil))
86   ;; the number of ticks a bare function call takes. This is
87   ;; factored into the other overheads, but not used for itself.
88   (call (required-argument) :type single-float :read-only t)
89   ;; the number of ticks that will be charged to a profiled
90   ;; function due to the profiling code
91   (internal (required-argument) :type single-float :read-only t)
92   ;; the number of ticks of overhead for profiling that a single
93   ;; profiled call adds to the total runtime for the program
94   (total (required-argument) :type single-float :read-only t))
95 (defvar *overhead*)
96 (declaim (type overhead *overhead*))
97 \f
98 ;;;; profile encapsulations
99
100 ;;; Trade off space for time by handling the usual all-FIXNUM cases
101 ;;; inline.
102 (defmacro fastbig- (x y)
103   (once-only ((x x) (y y))
104     `(if (and (typep ,x '(and fixnum unsigned-byte))
105               (typep ,y '(and fixnum unsigned-byte)))
106          ;; special case: can use fixnum arithmetic and be guaranteed
107          ;; the result is also a fixnum
108          (- ,x ,y)
109          ;; general case
110          (- ,x ,y))))
111 (defmacro fastbig-1+ (x)
112   (once-only ((x x))
113     `(if (typep ,x 'index)
114          (1+ ,x)
115          (1+ ,x))))
116
117 ;;; Return a collection of closures over the same lexical context,
118 ;;;   (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN).
119 ;;;
120 ;;; ENCAPSULATION-FUN is a plug-in replacement for ENCAPSULATED-FUN,
121 ;;; which updates statistics whenver it's called.
122 ;;;
123 ;;; READ-STATS-FUN returns the statistics:
124 ;;;   (VALUES COUNT TIME CONSING PROFILE).
125 ;;; COUNT is the count of calls to ENCAPSULATION-FUN. TICKS is
126 ;;; the total number of ticks spent in ENCAPSULATED-FUN.
127 ;;; CONSING is the total consing of ENCAPSULATION-FUN. PROFILE is the
128 ;;; number of calls to the profiled function, stored for the purposes
129 ;;; of trying to estimate that part of profiling overhead which occurs
130 ;;; outside the interval between the profile wrapper function's timer
131 ;;; calls.
132 ;;;
133 ;;; CLEAR-STATS-FUN clears the statistics.
134 ;;;
135 ;;; (The reason for implementing this as coupled closures, with the
136 ;;; counts built into the lexical environment, is that we hope this
137 ;;; will minimize profiling overhead.)
138 (defun profile-encapsulation-lambdas (encapsulated-fun)
139   (declare (type function encapsulated-fun))
140   (let* ((count 0)
141          (ticks 0)
142          (consing 0)
143          (profiles 0))
144     (declare (type (or pcounter fixnum) count ticks consing profiles))
145     (values
146      ;; ENCAPSULATION-FUN
147      (lambda (sb-c:&more arg-context arg-count)
148        (declare (optimize speed safety))
149        ;; Make sure that we're not recursing infinitely.
150        (when (boundp '*computing-profiling-data-for*)
151          (unprofile-all) ; to avoid further recursion
152          (error "~@<When computing profiling data for ~S, the profiled function ~S was called. To get out of this infinite recursion, all functions have been unprofiled. (Since the profiling system evidently uses ~S in its computations, it looks as though it's a bad idea to profile it.)~:@>"
153                 *computing-profiling-data-for*
154                 encapsulated-fun
155                 encapsulated-fun))
156        ;; FIXME: Probably when this is stable, we should optimize (SAFETY 0).
157        (fastbig-incf-pcounter-or-fixnum count 1)
158        (let ((dticks 0)
159              (dconsing 0)
160              (inner-enclosed-profiles 0))
161          (declare (type unsigned-byte dticks dconsing))
162          (declare (type unsigned-byte inner-enclosed-profiles))
163          (aver (typep dticks 'unsigned-byte))
164          (aver (typep dconsing 'unsigned-byte))
165          (aver (typep inner-enclosed-profiles 'unsigned-byte))
166          (multiple-value-prog1
167              (let* ((start-ticks (get-internal-ticks))
168                     (*enclosed-ticks* 0)
169                     (*enclosed-consing* 0)
170                     (*enclosed-profiles* 0)
171                     (nbf-pcounter *n-bytes-freed-or-purified-pcounter*)
172                     ;; Typically NBF-PCOUNTER will represent a bignum.
173                     ;; In general we don't want to cons up a new
174                     ;; bignum for every encapsulated call, so instead
175                     ;; we keep track of the PCOUNTER internals, so
176                     ;; that as long as we only cons small amounts,
177                     ;; we'll almost always just do fixnum arithmetic.
178                     ;; (And for encapsulated functions which cons
179                     ;; large amounts, then we don't much care about a
180                     ;; single extra consed bignum.)
181                     (start-consing-integer (pcounter-integer nbf-pcounter))
182                     (start-consing-fixnum (pcounter-fixnum nbf-pcounter)))
183                (declare (inline pcounter-or-fixnum->integer))
184                (multiple-value-prog1
185                    (multiple-value-call encapsulated-fun
186                                         (sb-c:%more-arg-values arg-context
187                                                                0
188                                                                arg-count))
189                  (let ((*computing-profiling-data-for* encapsulated-fun))
190                    (setf dticks (fastbig- (get-internal-ticks) start-ticks))
191                    (setf dconsing
192                          (if (eq (pcounter-integer nbf-pcounter)
193                                  start-consing-integer)
194                              (- (pcounter-fixnum nbf-pcounter)
195                                 start-consing-fixnum)
196                              (- (get-bytes-consed)
197                                 (+ (pcounter-integer nbf-pcounter)
198                                    (pcounter-fixnum nbf-pcounter)))))
199                    (setf inner-enclosed-profiles
200                          (pcounter-or-fixnum->integer *enclosed-profiles*))
201                    (let ((net-dticks (fastbig- dticks *enclosed-ticks*)))
202                      (fastbig-incf-pcounter-or-fixnum ticks net-dticks))
203                    (let ((net-dconsing (fastbig- dconsing *enclosed-consing*)))
204                      (fastbig-incf-pcounter-or-fixnum consing net-dconsing))
205                    (fastbig-incf-pcounter-or-fixnum profiles
206                                                     inner-enclosed-profiles))))
207            (fastbig-incf-pcounter-or-fixnum *enclosed-ticks* dticks)
208            (fastbig-incf-pcounter-or-fixnum *enclosed-consing* dconsing)
209            (fastbig-incf-pcounter-or-fixnum *enclosed-profiles*
210                                             (fastbig-1+
211                                              inner-enclosed-profiles)))))
212      ;; READ-STATS-FUN
213      (lambda ()
214        (values (pcounter-or-fixnum->integer count)
215                (pcounter-or-fixnum->integer ticks)
216                (pcounter-or-fixnum->integer consing)
217                (pcounter-or-fixnum->integer profiles)))
218      ;; CLEAR-STATS-FUN
219      (lambda ()
220        (setf count 0
221              ticks 0
222              consing 0
223              profiles 0)))))
224 \f
225 ;;;; interfaces
226
227 ;;; A symbol or (SETF FOO) list names a function, a string names all
228 ;;; the functions named by symbols in the named package.
229 (defun mapc-on-named-functions (function names)
230   (dolist (name names)
231     (etypecase name
232       (symbol (funcall function name))
233       (list
234        ;; We call this just for the side effect of checking that
235        ;; NAME is a legal function name:
236        (function-name-block-name name)
237        ;; Then we map onto it.
238        (funcall function name))
239       (string (let ((package (find-undeleted-package-or-lose name)))
240                 (do-symbols (symbol package)
241                   (when (eq (symbol-package symbol) package)
242                     (when (fboundp symbol)
243                       (funcall function symbol))
244                     (let ((setf-name `(setf ,symbol)))
245                       (when (fboundp setf-name)
246                         (funcall function setf-name)))))))))
247   (values))
248
249 ;;; Profile the named function, which should exist and not be profiled
250 ;;; already.
251 (defun profile-1-unprofiled-function (name)
252   (declare #.*optimize-byte-compilation*)
253   (let ((encapsulated-fun (fdefinition name)))
254     (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
255         (profile-encapsulation-lambdas encapsulated-fun)
256       (setf (fdefinition name)
257             encapsulation-fun)
258       (setf (gethash name *profiled-function-name->info*)
259             (make-profile-info :name name
260                                :encapsulated-fun encapsulated-fun
261                                :encapsulation-fun encapsulation-fun
262                                :read-stats-fun read-stats-fun
263                                :clear-stats-fun clear-stats-fun))
264       (values))))
265
266 ;;; Profile the named function. If already profiled, unprofile first.
267 (defun profile-1-function (name)
268   (declare #.*optimize-byte-compilation*)
269   (cond ((fboundp name)
270          (when (gethash name *profiled-function-name->info*)
271            (warn "~S is already profiled, so unprofiling it first." name)
272            (unprofile-1-function name))
273          (profile-1-unprofiled-function name))
274         (t
275          (warn "ignoring undefined function ~S" name)))
276   (values))
277
278 ;;; Unprofile the named function, if it is profiled.
279 (defun unprofile-1-function (name)
280   (declare #.*optimize-byte-compilation*)
281   (let ((pinfo (gethash name *profiled-function-name->info*)))
282     (cond (pinfo
283            (remhash name *profiled-function-name->info*)
284            (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
285                (setf (fdefinition name) (profile-info-encapsulated-fun pinfo))
286                (warn "preserving current definition of redefined function ~S"
287                      name)))
288           (t
289            (warn "~S is not a profiled function." name))))
290   (values))
291
292 (defmacro profile (&rest names)
293   #+sb-doc
294   "PROFILE Name*
295
296    If no names are supplied, return the list of profiled functions.
297
298    If names are supplied, wrap profiling code around the named functions.
299    As in TRACE, the names are not evaluated. A symbol names a function.
300    A string names all the functions named by symbols in the named
301    package. If a function is already profiled, then unprofile and
302    reprofile (useful to notice function redefinition.)  If a name is
303    undefined, then we give a warning and ignore it. See also
304    UNPROFILE, REPORT and RESET."
305   (declare #.*optimize-byte-compilation*)
306   (if (null names)
307       `(loop for k being each hash-key in *profiled-function-name->info*
308              collecting k)
309       `(mapc-on-named-functions #'profile-1-function ',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   (declare #.*optimize-byte-compilation*)
319   (if names
320       `(mapc-on-named-functions #'unprofile-1-function ',names)
321       `(unprofile-all)))
322
323 (defun unprofile-all ()
324   (declare #.*optimize-byte-compilation*)
325   (dohash (name profile-info *profiled-function-name->info*)
326     (declare (ignore profile-info))
327     (unprofile-1-function name)))
328
329 (defun reset ()
330   "Reset the counters for all profiled functions."
331   (dohash (name profile-info *profiled-function-name->info*)
332     (declare (ignore name))
333     (funcall (profile-info-clear-stats-fun profile-info))))
334 \f
335 ;;;; reporting results
336
337 (defstruct (time-info (:copier nil))
338   name
339   calls
340   seconds
341   consing)
342
343 ;;; Return our best guess for the run time in a function, subtracting
344 ;;; out factors for profiling overhead. We subtract out the internal
345 ;;; overhead for each call to this function, since the internal
346 ;;; overhead is the part of the profiling overhead for a function that
347 ;;; is charged to that function.
348 ;;;
349 ;;; We also subtract out a factor for each call to a profiled function
350 ;;; within this profiled function. This factor is the total profiling
351 ;;; overhead *minus the internal overhead*. We don't subtract out the
352 ;;; internal overhead, since it was already subtracted when the nested
353 ;;; profiled functions subtracted their running time from the time for
354 ;;; the enclosing function.
355 (defun compensate-time (calls ticks profile)
356   (let ((raw-compensated
357          (- (/ (float ticks) (float +ticks-per-second+))
358             (* (overhead-internal *overhead*) (float calls))
359             (* (- (overhead-total *overhead*)
360                   (overhead-internal *overhead*))
361                (float profile)))))
362     (max raw-compensated 0.0)))
363
364 (defun report ()
365   "Report results from profiling. The results are approximately adjusted
366 for profiling overhead. The compensation may be rather inaccurate when
367 bignums are involved in runtime calculation, as in a very-long-running
368 Lisp process."
369   (declare #.*optimize-external-despite-byte-compilation*)
370   (unless (boundp '*overhead*)
371     (setf *overhead*
372           (compute-overhead)))
373   (let ((time-info-list ())
374         (no-call-name-list ()))
375     (dohash (name pinfo *profiled-function-name->info*)
376       (unless (eq (fdefinition name)
377                   (profile-info-encapsulation-fun pinfo))
378         (warn "Function ~S has been redefined, so times may be inaccurate.~@
379                PROFILE it again to record calls to the new definition."
380               name))
381       (multiple-value-bind (calls ticks consing profile)
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                   time-info-list))))
392
393     (setf time-info-list
394           (sort time-info-list
395                 #'>=
396                 :key #'time-info-seconds))
397
398     (format *trace-output*
399             "~&  seconds  |  consed   |  calls  |  sec/call  |  name~@
400                ------------------------------------------------------~%")
401
402     (let ((total-time 0.0)
403           (total-consed 0)
404           (total-calls 0))
405       (dolist (time-info time-info-list)
406         (incf total-time (time-info-seconds time-info))
407         (incf total-calls (time-info-calls time-info))
408         (incf total-consed (time-info-consing time-info))
409         (format *trace-output*
410                 "~10,3F | ~9:D | ~7:D | ~10,6F | ~S~%"
411                 (time-info-seconds time-info)
412                 (time-info-consing time-info)
413                 (time-info-calls time-info)
414                 (/ (time-info-seconds time-info)
415                    (float (time-info-calls time-info)))
416                 (time-info-name time-info)))
417       (format *trace-output*
418               "------------------------------------------------------~@
419               ~10,3F | ~9:D | ~7:D |        | Total~%"
420               total-time total-consed total-calls)
421       (format *trace-output*
422               "~%estimated total profiling overhead: ~4,2F seconds~%"
423               (* (overhead-total *overhead*) (float total-calls)))
424       (format *trace-output*
425               "~&overhead estimation parameters:~%  ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%"
426               (overhead-call *overhead*)
427               (overhead-total *overhead*)
428               (overhead-internal *overhead*)))
429
430     (when no-call-name-list
431       (format *trace-output*
432               "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
433               (sort no-call-name-list #'string<
434                     :key (lambda (name)
435                            (symbol-name (function-name-block-name name))))))
436
437     (values)))
438 \f
439 ;;;; overhead estimation
440
441 ;;; We average the timing overhead over this many iterations.
442 ;;;
443 ;;; (This is a variable, not a constant, so that it can be set in
444 ;;; .sbclrc if desired. Right now, that's an unsupported extension
445 ;;; that I (WHN) use for my own experimentation, but it might
446 ;;; become supported someday. Comments?)
447 (declaim (type unsigned-byte *timer-overhead-iterations*))
448 (defvar *timer-overhead-iterations*
449   500000)
450
451 ;;; a dummy function that we profile to find profiling overhead
452 (declaim (notinline compute-overhead-aux))
453 (defun compute-overhead-aux (x)
454   (declare (ignore x)))
455
456 ;;; Return a newly computed OVERHEAD object.
457 (defun compute-overhead ()
458   (format *debug-io* "~&measuring PROFILE overhead..")
459   (flet ((frob ()
460            (let ((start (get-internal-ticks))
461                  (fun (symbol-function 'compute-overhead-aux)))
462              (dotimes (i *timer-overhead-iterations*)
463                (funcall fun fun))
464              (/ (float (- (get-internal-ticks) start))
465                 (float +ticks-per-second+)
466                 (float *timer-overhead-iterations*)))))
467     (let (;; Measure unprofiled calls to estimate call overhead.
468           (call-overhead (frob))
469           total-overhead
470           internal-overhead)
471       ;; Measure profiled calls to estimate profiling overhead.
472       (unwind-protect
473           (progn
474             (profile compute-overhead-aux)
475             (setf total-overhead
476                   (- (frob) call-overhead)))
477         (let* ((pinfo (gethash 'compute-overhead-aux
478                                *profiled-function-name->info*))
479                (read-stats-fun (profile-info-read-stats-fun pinfo))
480                (time (nth-value 1 (funcall read-stats-fun))))
481           (setf internal-overhead
482                 (/ (float time)
483                    (float +ticks-per-second+)
484                    (float *timer-overhead-iterations*))))
485         (unprofile compute-overhead-aux))
486       (prog1
487           (make-overhead :call call-overhead
488                          :total total-overhead
489                          :internal internal-overhead)
490         (format *debug-io* "done~%")))))
491
492 ;;; It would be bad to compute *OVERHEAD*, save it into a .core file,
493 ;;; then load the old *OVERHEAD* value from the .core file into a
494 ;;; different machine running at a different speed. We avoid this by
495 ;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
496 (pushnew (lambda ()
497            (makunbound '*overhead*))
498          *before-save-initializations*)