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