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
(eval-when (:compile-toplevel :load-toplevel)
13
(:export "PROFILE" "REPORT" "RESET" "UNPROFILE" "UNPROFILE-ALL"))
16
(in-package "PROFILE")
18
;;;; reading internal run time with high resolution and low overhead
20
(defconstant +ticks-per-second+ internal-time-units-per-second)
22
(eval-when (:compile-toplevel)
23
(defmacro get-internal-ticks () '(get-internal-run-time))
25
(defmacro dohash (((key value) hash &key locked) &body body)
28
`(with-hash-table-iterator (,it ,hash)
29
(loop (multiple-value-bind (,entry ,key ,value)
31
(unless ,entry (return))
35
(defmacro without-package-locks (&rest body)
39
(defconstant +wrap+ (ffi:c-inline () () :object "ecl_make_unsigned_integer(~((size_t)0))"
42
(defun get-bytes-consed (orig)
43
(let ((bytes (ffi:c-inline () () :object "ecl_make_unsigned_integer(GC_get_total_bytes())"
46
(+ (- +wrap+ orig) bytes)
49
(deftype counter () '(integer 0 *))
52
;;;; implementation-dependent interfaces
55
;;; To avoid unnecessary consing in the "encapsulation" code, we want
56
;;; find out the number of required arguments, and use &REST to
57
;;; capture only non-required arguments. This function returns (VALUES
58
;;; MIN-ARGS OPTIONALS-P), where MIN-ARGS is the number of required
59
;;; arguments and OPTIONALS-P is true iff there are any non-required
60
;;; arguments (such as &OPTIONAL, &REST, or &KEY).
61
(declaim (ftype (function ((or symbol cons)) (values fixnum t)) fun-signature))
62
(defun fun-signature (name)
63
(let ((type (info :function :type name)))
64
(cond ((not (fun-type-p type))
67
(values (length (fun-type-required type))
68
(or (fun-type-optional type)
70
(fun-type-rest type)))))))
73
;;;; global data structures
75
;;; We associate a PROFILE-INFO structure with each profiled function
76
;;; name. This holds the functions that we call to manipulate the
77
;;; closure which implements the encapsulation.
78
(defvar *profiled-fun-name->info*
80
;; EQL testing isn't good enough for generalized function names
84
(defstruct (profile-info (:copier nil))
85
(name (missing-arg) :read-only t)
86
(encapsulated-fun (missing-arg) :type function :read-only t)
87
(encapsulation-fun (missing-arg) :type function :read-only t)
88
(read-stats-fun (missing-arg) :type function :read-only t)
89
(clear-stats-fun (missing-arg) :type function :read-only t))
91
;;; These variables are used to subtract out the time and consing for
92
;;; recursive and other dynamically nested profiled calls. The total
93
;;; resource consumed for each nested call is added into the
94
;;; appropriate variable. When the outer function returns, these
95
;;; amounts are subtracted from the total.
96
(defvar *enclosed-ticks* 0)
97
(defvar *enclosed-consing* 0)
98
(declaim (type counter *enclosed-ticks* *enclosed-consing*))
100
;;; This variable is also used to subtract out time for nested
101
;;; profiled calls. The time inside the profile wrapper call --
102
;;; between its two calls to GET-INTERNAL-TICKS -- is accounted
103
;;; for by the *ENCLOSED-TIME* variable. However, there's also extra
104
;;; overhead involved, before we get to the first call to
105
;;; GET-INTERNAL-TICKS, and after we get to the second call. By
106
;;; keeping track of the count of enclosed profiled calls, we can try
107
;;; to compensate for that.
108
(defvar *enclosed-profiles* 0)
109
(declaim (type counter *enclosed-profiles*))
111
;;; the encapsulated function we're currently computing profiling data
112
;;; for, recorded so that we can detect the problem of
113
;;; PROFILE-computing machinery calling a function which has itself
115
(defvar *computing-profiling-data-for*)
117
;;; the components of profiling overhead
118
(defstruct (overhead (:copier nil))
119
;; the number of ticks a bare function call takes. This is
120
;; factored into the other overheads, but not used for itself.
121
(call (missing-arg) :type single-float :read-only t)
122
;; the number of ticks that will be charged to a profiled
123
;; function due to the profiling code
124
(internal (missing-arg) :type single-float :read-only t)
125
;; the number of ticks of overhead for profiling that a single
126
;; profiled call adds to the total runtime for the program
127
(total (missing-arg) :type single-float :read-only t))
129
(declaim (type overhead *overhead*))
130
(makunbound '*overhead*) ; in case we reload this file when tweaking
132
;;;; profile encapsulations
134
;;; Trade off space for time by handling the usual all-FIXNUM cases inline.
135
(eval-when (:compile-toplevel)
136
(defmacro fastbig- (x y)
138
(defmacro fastbig-1+ (x)
141
;;; Return a collection of closures over the same lexical context,
142
;;; (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN).
144
;;; ENCAPSULATION-FUN is a plug-in replacement for ENCAPSULATED-FUN,
145
;;; which updates statistics whenever it's called.
147
;;; READ-STATS-FUN returns the statistics:
148
;;; (VALUES COUNT TIME CONSING PROFILE).
149
;;; COUNT is the count of calls to ENCAPSULATION-FUN. TICKS is
150
;;; the total number of ticks spent in ENCAPSULATED-FUN.
151
;;; CONSING is the total consing of ENCAPSULATION-FUN. PROFILE is the
152
;;; number of calls to the profiled function, stored for the purposes
153
;;; of trying to estimate that part of profiling overhead which occurs
154
;;; outside the interval between the profile wrapper function's timer
157
;;; CLEAR-STATS-FUN clears the statistics.
159
;;; (The reason for implementing this as coupled closures, with the
160
;;; counts built into the lexical environment, is that we hope this
161
;;; will minimize profiling overhead.)
162
(defun profile-encapsulation-lambdas (encapsulated-fun)
163
(declare (type function encapsulated-fun))
168
(declare (type counter count ticks consing profiles))
172
(declare (optimize speed safety))
173
;; Make sure that we're not recursing infinitely.
174
(when (boundp '*computing-profiling-data-for*)
175
(unprofile-all) ; to avoid further recursion
176
(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.)~:@>"
177
*computing-profiling-data-for*
180
;; FIXME: Probably when this is stable, we should optimize (SAFETY 0).
184
(inner-enclosed-profiles 0)
185
(old-enclosed-ticks *enclosed-ticks*)
186
(old-enclosed-consing *enclosed-consing*)
187
(old-enclosed-profiles *enclosed-profiles*)
188
(start-ticks (get-internal-ticks))
189
(start-consed (get-bytes-consed 0)))
192
(setf *enclosed-ticks* 0
193
*enclosed-profiles* 0
194
*enclosed-consing* 0)
195
(apply encapsulated-fun args))
196
(setf dticks (- (get-internal-ticks) start-ticks))
197
(setf dconsing (get-bytes-consed start-consed))
198
(setf inner-enclosed-profiles *enclosed-profiles*)
199
(let ((net-dticks (- dticks *enclosed-ticks*)))
200
(incf ticks net-dticks))
201
(let ((net-dconsing (- dconsing *enclosed-consing*)))
202
(incf consing net-dconsing))
203
(incf profiles inner-enclosed-profiles)
204
(setf *enclosed-ticks* (+ old-enclosed-ticks dticks)
205
*enclosed-consing* (+ old-enclosed-consing dconsing)
206
*enclosed-profiles* (+ old-enclosed-profiles inner-enclosed-profiles 1)))))
209
(values count ticks consing profiles))
219
;;; A symbol or (SETF FOO) list names a function, a string names all
220
;;; the functions named by symbols in the named package.
221
(defun mapc-on-named-funs (function names)
224
(symbol (funcall function name))
226
(legal-fun-name-or-type-error name)
227
;; Then we map onto it.
228
(funcall function name))
229
(string (let ((package (find-undeleted-package-or-lose name)))
230
(do-symbols (symbol package)
231
(when (eq (symbol-package symbol) package)
232
(when (and (fboundp symbol)
233
(not (macro-function symbol))
234
(not (special-operator-p symbol)))
235
(funcall function symbol))
236
(let ((setf-name `(setf ,symbol)))
237
(when (fboundp setf-name)
238
(funcall function setf-name)))))))))
241
;;; Profile the named function, which should exist and not be profiled
243
(defun profile-1-unprofiled-fun (name)
244
(let ((encapsulated-fun (fdefinition name)))
245
(multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
246
(profile-encapsulation-lambdas encapsulated-fun)
247
(without-package-locks
248
(setf (fdefinition name)
250
(setf (gethash name *profiled-fun-name->info*)
251
(make-profile-info :name name
252
:encapsulated-fun encapsulated-fun
253
:encapsulation-fun encapsulation-fun
254
:read-stats-fun read-stats-fun
255
:clear-stats-fun clear-stats-fun))
258
;;; Profile the named function. If already profiled, unprofile first.
259
(defun profile-1-fun (name)
260
(cond ((fboundp name)
261
(when (gethash name *profiled-fun-name->info*)
262
(warn "~S is already profiled, so unprofiling it first." name)
263
(unprofile-1-fun name))
264
(profile-1-unprofiled-fun name))
266
(warn "ignoring undefined function ~S" name)))
269
;;; Unprofile the named function, if it is profiled.
270
(defun unprofile-1-fun (name)
271
(let ((pinfo (gethash name *profiled-fun-name->info*)))
273
(remhash name *profiled-fun-name->info*)
274
(if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
275
(without-package-locks
276
(setf (fdefinition name) (profile-info-encapsulated-fun pinfo)))
277
(warn "preserving current definition of redefined function ~S"
280
(warn "~S is not a profiled function." name))))
283
(defmacro profile (&rest names)
286
If no names are supplied, return the list of profiled functions.
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."
296
`(loop for k being each hash-key in *profiled-fun-name->info*
298
`(mapc-on-named-funs #'profile-1-fun ',names)))
300
(defmacro unprofile (&rest names)
301
"Unwrap any profiling code around the named functions, or if no names
302
are given, unprofile all profiled functions. A symbol names
303
a function. A string names all the functions named by symbols in the
304
named package. NAMES defaults to the list of names of all currently
307
`(mapc-on-named-funs #'unprofile-1-fun ',names)
310
(defun unprofile-all ()
311
(dohash ((name profile-info) *profiled-fun-name->info*
313
(declare (ignore profile-info))
314
(unprofile-1-fun name)))
317
"Reset the counters for all profiled functions."
318
(dohash ((name profile-info) *profiled-fun-name->info* :locked t)
319
(declare (ignore name))
320
(funcall (profile-info-clear-stats-fun profile-info))))
322
;;;; reporting results
324
(defstruct (time-info (:copier nil))
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.
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*))
349
(max raw-compensated 0.0)))
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
356
(unless (boundp '*overhead*)
359
(let ((time-info-list ())
360
(no-call-name-list ()))
361
(dohash ((name pinfo) *profiled-fun-name->info* :locked t)
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."
367
(multiple-value-bind (calls ticks consing profile)
368
(funcall (profile-info-read-stats-fun pinfo))
370
(push name no-call-name-list)
371
(push (make-time-info :name name
373
:seconds (compensate-time calls
382
:key #'time-info-seconds))
383
(print-profile-table time-info-list)
385
(when no-call-name-list
386
(format *trace-output*
387
"~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
388
(sort no-call-name-list #'string<
390
(symbol-name name)))))
395
(defun print-profile-table (time-info-list)
396
(let ((total-seconds 0.0)
399
(seconds-width (length "seconds"))
400
(consed-width (length "consed"))
401
(calls-width (length "calls"))
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))
410
calls-width (max (length (format nil "~:D" total-calls))
412
consed-width (max (length (format nil "~:D" total-consed))
416
(dotimes (i (+ seconds-width consed-width calls-width
417
sec/call-width name-width
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")
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)))
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)
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*)))))
456
;;;; overhead estimation
458
;;; We average the timing overhead over this many iterations.
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*
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)))
473
;;; Return a newly computed OVERHEAD object.
474
(defun compute-overhead ()
475
(format *debug-io* "~&measuring PROFILE overhead..")
477
(let ((start (get-internal-ticks))
478
(fun (symbol-function 'compute-overhead-aux)))
479
(declare (type function fun))
480
(dotimes (i *timer-overhead-iterations*)
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))
489
;; Measure profiled calls to estimate profiling overhead.
492
(profile compute-overhead-aux)
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
501
(float +ticks-per-second+)
502
(float *timer-overhead-iterations*))))
503
(unprofile compute-overhead-aux))
505
(make-overhead :call call-overhead
506
:total total-overhead
507
:internal internal-overhead)
508
(format *debug-io* "done~%")))))
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*)))
added
removed
contrib/profile/profile.lisp
