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

Contents of /src/benchmarks/oprofile.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide 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 ram 1.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