/[cmucl]/src/benchmarks/oprofile.lisp
ViewVC logotype

Contents of /src/benchmarks/oprofile.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Mon Dec 17 19:46:24 1990 UTC (23 years, 4 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Initial revision
1 ;;; -*- Mode: Lisp; Package: Profile; Log: profile.log -*-
2 ;;;
3 ;;; This code has been placed in the public domain by the author.
4 ;;; It is distributed without warranty of any kind.
5 ;;;
6 ;;; Description: Simple profiling facility.
7 ;;;
8 ;;; Author: Skef Wholey, Rob MacLachlan
9 ;;;
10 ;;; Current maintainer: Rob MacLachlan
11 ;;;
12 ;;; Address: Carnegie-Mellon University
13 ;;; Computer Science Department
14 ;;; Pittsburgh, PA 15213
15 ;;;
16 ;;; Net address: ram@cs.cmu.edu
17 ;;;
18 ;;; Copyright status: Public domain.
19 ;;;
20 ;;; Compatibility: Runs in any valid Common Lisp. Three small implementation-
21 ;;; dependent changes can be made to improve performance and prettiness.
22 ;;;
23 ;;; Dependencies: The macro Quickly-Get-Time and the function
24 ;;; Required-Arguments should probably be tailored to the implementation for
25 ;;; the best results. They will default to working, albeit inefficent, forms
26 ;;; in non-CMU implementations. The Total-Consing macro is used to profile
27 ;;; consing: in unknown implementations 0 will be used.
28 ;;; See the "Implementation Parameters" section.
29 ;;;
30 ;;; Note: a timing overhead factor is computed at load time. This will be
31 ;;; incorrect if profiling code is run in a different environment than this
32 ;;; file was loaded in. For example, saving a core image on a high
33 ;;; performance machine and running it on a low performance one will result
34 ;;; in use of an erroneously small timing overhead factor.
35 ;;;
36 (in-package "OPROFILE")
37
38 (export '(*timed-functions* profile unprofile report-time reset-time))
39
40
41
42 (progn
43 #-:cmu
44 (eval-when (compile eval)
45 (warn
46 "You may want to supply an implementation-specific ~
47 Quickly-Get-Time function."))
48
49 (defconstant quick-time-units-per-second internal-time-units-per-second)
50
51 (defmacro quickly-get-time ()
52 `(get-internal-run-time)))
53
54
55 ;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
56 ;;; number of required arguments, and use &rest to capture only non-required
57 ;;; arguments. The function Required-Arguments returns two values: the first
58 ;;; is the number of required arguments, and the second is T iff there are any
59 ;;; non-required arguments (e.g. &optional, &rest, &key).
60
61 #+nil
62 (defun required-arguments (name)
63 (let ((function (symbol-function name)))
64 (if (eql (system:%primitive get-type function) system:%function-type)
65 (let ((min (ldb system:%function-min-args-byte
66 (system:%primitive header-ref function
67 system:%function-min-args-slot)))
68 (max (ldb system:%function-max-args-byte
69 (system:%primitive header-ref function
70 system:%function-max-args-slot)))
71 (rest (ldb system:%function-rest-arg-byte
72 (system:%primitive header-ref function
73 system:%function-rest-arg-slot)))
74 (key (ldb system:%function-keyword-arg-byte
75 (system:%primitive header-ref function
76 system:%function-keyword-arg-slot))))
77 (values min (or (/= min max) (/= rest 0) (/= key 0))))
78 (values 0 t))))
79
80
81 #-:cmu
82 (progn
83 (eval-when (compile eval)
84 (warn
85 "You may want to add an implementation-specific Required-Arguments function."))
86 (eval-when (load eval)
87 (defun required-arguments (name)
88 (declare (ignore name))
89 (values 0 t))))
90
91
92
93 ;;; The Total-Consing macro is called to find the total number of bytes consed
94 ;;; since the beginning of time.
95
96 #+cmu
97 (defmacro total-consing () '(ext:get-bytes-consed))
98
99 #-:cmu
100 (progn
101 (eval-when (compile eval)
102 (warn "No consing will be reported unless a Total-Consing function is ~
103 defined."))
104
105 (defmacro total-consing () '0))
106
107
108 (defvar *timed-functions* ()
109 "List of functions that are currently being timed.")
110
111
112 (defmacro profile (&rest names)
113 "Wraps profiling code around the named functions. The Names are not evaluated,
114 as in Trace."
115 (do ((names names (cdr names))
116 (stuff ()))
117 ((null names)
118 ;; Keep the compiler quiet by sending standard output to bit bucket.
119 `(compiler-let (#|(*standard-output* (make-broadcast-stream))|#)
120 ,@stuff
121 (values)))
122 (push (profile-1-function (car names)) stuff)))
123
124
125 ;;; A function is profiled by replacing its definition with a closure created by
126 ;;; the following function. The closure records the starting time, calls the
127 ;;; original function, and records finishing time. Other closures are used to
128 ;;; perform various operations on the encapsulated function.
129
130 (defun profile-1-function (name)
131 (multiple-value-bind (min-args optionals-p)
132 (required-arguments name)
133 (let ((required-args ()))
134 (dotimes (i min-args)
135 (push (gensym) required-args))
136 `(funcall
137 (compile
138 nil
139 ;; Use ' instead of #' below so guaranteed null lexical environment.
140 '(lambda ()
141 (let* ((time 0)
142 (count 0)
143 (consed 0)
144 (old-definition (symbol-function ',name))
145 (new-definition
146 #'(lambda (,@required-args
147 ,@(if optionals-p
148 `(&rest optional-args)))
149 (incf count)
150 (let ((old-time time)
151 (start-time (quickly-get-time))
152 (old-consed consed)
153 (start-consed (total-consing)))
154 (multiple-value-prog1
155 ,(if optionals-p
156 `(apply old-definition
157 ,@required-args optional-args)
158 `(funcall old-definition ,@required-args))
159 (setq time
160 (+ old-time (- (quickly-get-time)
161 start-time)))
162 (setq consed
163 (+ old-consed (- (total-consing)
164 start-consed))))))))
165 (pushnew ',name *timed-functions*)
166 (setf (get ',name 'read-time)
167 #'(lambda ()
168 (values count time consed))
169 (get ',name 'reset-time)
170 #'(lambda ()
171 (setq count 0)
172 (setq time 0)
173 (setq consed 0)
174 t)
175 (symbol-function ',name)
176 new-definition
177 (get ',name 'reset-definition)
178 #'(lambda ()
179 (remprop ',name 'read-time)
180 (remprop ',name 'reset-time)
181 (if (eq (symbol-function ',name) new-definition)
182 (setf (symbol-function ',name) old-definition)
183 (warn "The function ~S was redefined without ~
184 unprofiling and reprofiling.~%~
185 Timing figures have not been updated ~
186 since that redefinition."
187 ',name))
188 (remprop ',name 'reset-definition)
189 (setq *timed-functions*
190 (delete ',name *timed-functions*))
191 nil)))))))))
192
193
194 (defmacro unprofile (&rest names)
195 "Unwraps the profiling code around the named functions. Names defaults to the
196 list of all currently profiled functions."
197 `(dolist (name ,(if names `',names '*timed-functions*) (values))
198 (unprofile-1-function name)))
199
200 (defun unprofile-1-function (name)
201 (if (get name 'reset-definition)
202 (funcall (get name 'reset-definition))
203 (error "~S is not a function being profiled." name)))
204
205
206 (defmacro report-time (&rest names)
207 "Reports the time spent in the named functions. Names defaults to the list of
208 all currently profiled functions."
209 `(%report-times ,(if names `',names '*timed-functions*)))
210
211
212 ;;; We average the timing overhead over this many iterations.
213 ;;;
214 (defconstant timer-overhead-iterations 5000)
215
216 ;;; Compute-Time-Overhead -- Internal
217 ;;;
218 ;;; Return as a float the total number of seconds it takes to call both
219 ;;; Quickly-Get-Time and Total-Consing together, plus a funcall thrown in
220 ;;; to represent some of the other overhead. We also return a something
221 ;;; computed from the results in order to frustrate clever compilers.
222 ;;;
223 (defun compute-time-overhead-aux (x)
224 x)
225 (proclaim '(notinline compute-time-overhead-aux))
226 ;;;
227 (defun compute-time-overhead ()
228 (let ((foo 0)
229 (fun (symbol-function 'compute-time-overhead-aux))
230 (start (quickly-get-time)))
231 (funcall fun nil)
232 (dotimes (i timer-overhead-iterations)
233 (setq foo (logxor (funcall fun (quickly-get-time))
234 (total-consing)
235 foo)))
236 (let ((now (quickly-get-time)))
237 (values
238 (/ (float (- now start))
239 (float timer-overhead-iterations)
240 (float quick-time-units-per-second))
241 foo))))
242
243
244 (defvar *time-overhead* (compute-time-overhead))
245
246 (defstruct (time-info
247 (:constructor make-time-info (name calls time consing)))
248 name
249 calls
250 time
251 consing)
252
253
254 (defun %report-times (names)
255 (let ((info ())
256 (no-call ()))
257 (dolist (name names)
258 (multiple-value-bind
259 (calls time consing)
260 (funcall (or (get name 'read-time)
261 (error "~S is not profiled.")))
262 (if (zerop calls)
263 (push name no-call)
264 (let ((compensated
265 (- (/ (float time) (float quick-time-units-per-second))
266 (* *time-overhead* (float calls)))))
267 (push (make-time-info name calls
268 (if (minusp compensated) 0.0 compensated)
269 consing)
270 info)))))
271
272 (setq info (sort info #'>= :key #'time-info-time))
273
274 (format *trace-output*
275 "~& Seconds | Consed | Calls | Sec/Call | Name:~@
276 ------------------------------------------------------~%")
277
278 (let ((total-time 0.0)
279 (total-consed 0)
280 (total-calls 0))
281 (dolist (time info)
282 (incf total-time (time-info-time time))
283 (incf total-calls (time-info-calls time))
284 (incf total-consed (time-info-consing time))
285 (format *trace-output*
286 "~10,3F | ~9:D | ~7:D | ~10,5F | ~S~%"
287 (time-info-time time)
288 (time-info-consing time)
289 (time-info-calls time)
290 (/ (time-info-time time) (float (time-info-calls time)))
291 (time-info-name time)))
292 (format *trace-output*
293 "------------------------------------------------------~@
294 ~10,3F | ~9:D | ~7:D | | Total~%"
295 total-time total-consed total-calls)
296
297 (format *trace-output*
298 "~%Estimated total profiling overhead: ~4,2F seconds~%"
299 (* *time-overhead* (float total-calls) 2.0)))
300
301 (when no-call
302 (format *trace-output*
303 "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
304 (sort no-call #'string< :key #'symbol-name)))
305 (values)))
306
307
308 (defmacro reset-time (&rest names)
309 "Resets the time counter for the named functions. Names defaults to the list
310 of all currently profiled functions."
311 `(dolist (name ,(if names `',names '*timed-functions*) (values))
312 (reset-1-time name)))
313
314 (defun reset-1-time (name)
315 (if (get name 'reset-time)
316 (funcall (get name 'reset-time))
317 (error "~S is not a function being profiled.")))

  ViewVC Help
Powered by ViewVC 1.1.5