[4d57f2]: contrib / profile / profile.lisp Maximize Restore History

Download this file

profile.lisp    541 lines (480 with data), 21.6 kB

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