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