Commit | Line | Data |
---|---|---|
5ffa1c4c C |
1 | (setq rcs-prof- |
2 | "$Header: /usr/lib/lisp/RCS/prof.l,v 1.2 83/03/27 18:09:22 jkf Exp $") | |
3 | ||
4 | ;; prof | |
5 | ;; dynamic profiler for lisp -[Tue Mar 8 08:15:47 1983 by jkf]- | |
6 | ;; | |
7 | ;; use: | |
8 | ;; -> (load 'prof) ;may not be necessary if autoloading is set up | |
9 | ;; -> (prof-start) ; start the profiling | |
10 | ;; ... do what ever you want here, but don't do a (reset) since | |
11 | ;; that turns off profiling | |
12 | ;; -> (prof-end) ; type this when you are finished | |
13 | ;; -> (prof-report) ; then type this, it will list each funtion | |
14 | ;; ; that was called, who called this function | |
15 | ;; ; and who this function calls. | |
16 | ;; | |
17 | ;; prof uses the evalhook/funcallhook mechanism to get control everytime | |
18 | ;; a function is called. When it gets control, it knows what function | |
19 | ;; is doing the calling (via the Pcaller special variable) and what | |
20 | ;; function is being called. It maintains a running count for each | |
21 | ;; function of the functions which call it and the number of time they | |
22 | ;; do the calling. | |
23 | ;; | |
24 | ;; When prof-end is called, the profiling is turned off and the | |
25 | ;; records kept are inverted, that is for each function it is calculated | |
26 | ;; how many times it calls other functions. A list describing the results | |
27 | ;; is created and assigned to Profreport . When prof-report is called, | |
28 | ;; this record (value of Profreport) is printed in a nice human | |
29 | ;; readable way. | |
30 | ;; | |
31 | ;; multiple profiling runs can be made one after the other and all | |
32 | ;; counts will revert to zero. | |
33 | ;; | |
34 | ||
35 | ||
36 | (declare (special Pcalledby Pcalls Pfcns Pcaller evalhook funcallhook | |
37 | Profreport Ptotcalls Pcallcnt Profile-in-progress)) | |
38 | ||
39 | ;--- prof-start :: start profiling | |
40 | ; | |
41 | ; | |
42 | (defun prof-start nil | |
43 | (setq Pcalledby (gensym) ; plist tag for who calls us | |
44 | Pcalls (gensym) ; plist tag for who we call | |
45 | Pfcns (list '<top-lev>) ; list of all functions encountered | |
46 | Pcaller '<top-lev> ; function being evaluated | |
47 | Pcallcnt (gensym) ; plist tag for tot number of times called | |
48 | Ptotcalls 0 ; total number of function calls | |
49 | Profile-in-progress t) ; indicate we are begin done | |
50 | (sstatus translink nil) | |
51 | (setq evalhook 'Pevalhook* funcallhook 'Pfuncallhook*) | |
52 | (*rset t) | |
53 | (msg "profiling beginning" N) | |
54 | (sstatus evalhook t) | |
55 | t) | |
56 | ||
57 | ;--- prof-end :: turn off profiling and generate result list. | |
58 | ; | |
59 | (defun prof-end nil | |
60 | ; turn off profiling | |
61 | (sstatus evalhook nil) | |
62 | (setq evalhook nil funcallhook nil) | |
63 | (*rset nil) | |
64 | (setq Profile-in-progress nil) | |
65 | (msg (length Pfcns) " different functions called" N) | |
66 | ; generate a profile report | |
67 | ; we already know for each function, who calls that function, now | |
68 | ; we want to figure out who each function calls | |
69 | (do ((xx Pfcns (cdr xx)) | |
70 | (fcn)) | |
71 | ((null xx)) | |
72 | (setq fcn (car xx)) | |
73 | (do ((called (get fcn Pcalledby) (cdr called)) | |
74 | (callcnt 0)) | |
75 | ((null called) | |
76 | ; save total number of times this function was called | |
77 | (putprop fcn callcnt Pcallcnt) | |
78 | (setq Ptotcalls (+ callcnt Ptotcalls))) | |
79 | ; keep count of the number of time we've been called | |
80 | (setq callcnt (+ (cdar called) callcnt)) | |
81 | ; update data on caller. | |
82 | (putprop (caar called) | |
83 | (cons (cons fcn (cdar called)) | |
84 | (get (caar called) Pcalls)) | |
85 | Pcalls))) | |
86 | ||
87 | (msg Ptotcalls " function calls made" N) | |
88 | ||
89 | ; sort by total calls to function | |
90 | (setq Pfcns (sort Pfcns 'totcallsort)) | |
91 | ||
92 | ; generate report list, really a list of lists each one with this | |
93 | ; form: | |
94 | ; function-name info who-called-it number-of-times-called who-it-called | |
95 | ; | |
96 | ; the car of the report form is the total number of function calls made | |
97 | (do ((rep nil) | |
98 | (xx Pfcns (cdr xx))) | |
99 | ((null xx)(setq Profreport (cons Ptotcalls rep))) | |
100 | (setq rep (cons (list (car xx) | |
101 | (get (car xx) 'fcn-info) | |
102 | (get (car xx) Pcalledby) | |
103 | (get (car xx) Pcallcnt) | |
104 | (get (car xx) Pcalls)) | |
105 | rep))) | |
106 | 'done) | |
107 | ||
108 | (declare (special poport)) | |
109 | ||
110 | ;--- prof-report :: generate a human readable version of prof report | |
111 | ; input: Profreport (global) : variable set by (prof-end) | |
112 | ; | |
113 | (defun prof-report (&optional (filename nil file-p)) | |
114 | (if Profile-in-progress | |
115 | then (msg "[prof-end]" N) | |
116 | (prof-end)) | |
117 | (let ((totcalls (car Profreport)) | |
118 | (poport poport)) | |
119 | (cond (file-p (setq poport (outfile filename)))) | |
120 | (do ((xx (cdr Profreport) (cdr xx)) | |
121 | (name ) (info) (calledby) (calls) (callcnt)) | |
122 | ((null xx)) | |
123 | (setq name (caar xx) | |
124 | info (cadar xx) | |
125 | calledby (caddar xx) | |
126 | callcnt (cadddar xx) | |
127 | calls (caddddar xx)) | |
128 | (msg ":: " name " ") | |
129 | (pctprint callcnt totcalls) | |
130 | (If info then (msg " - " (cutatblank (cadr info)))) | |
131 | (msg N) | |
132 | (If calledby | |
133 | then (msg "Called by:" N) | |
134 | (do ((yy (sort calledby 'lesscdr) (cdr yy))) | |
135 | ((null yy)) | |
136 | (msg " " (cdar yy) " :: " (caar yy) N))) | |
137 | (If calls | |
138 | then (msg " Calls: " N) | |
139 | (do ((yy (sort calls 'lesscdr) (cdr yy))) | |
140 | ((null yy)) | |
141 | (msg " " (cdar yy) " :: " (caar yy) N))) | |
142 | (msg N N)) | |
143 | (cond (file-p (close poport))) | |
144 | nil)) | |
145 | ||
146 | ||
147 | ;--- totcallsort :: sort by number of calls and then alphabetically | |
148 | ; | |
149 | ; this is the predicate used when sorting the list of functions | |
150 | ; called during the profiling run. | |
151 | ; | |
152 | (defun totcallsort (x y) | |
153 | (let ((xc (get x Pcallcnt)) | |
154 | (yc (get y Pcallcnt))) | |
155 | (If (< xc yc) | |
156 | thenret | |
157 | elseif (= xc yc) | |
158 | then (alphalessp x y) | |
159 | else nil))) | |
160 | ||
161 | ;--- lesscdr :: sort by decreasing cdr's | |
162 | ; | |
163 | (defun lesscdr (x y) | |
164 | (> (cdr x) (cdr y))) | |
165 | ||
166 | ;--- pctprint :: print fraction and then percentage | |
167 | ; | |
168 | (defun pctprint (this tot) | |
169 | (msg this "/" tot " " (quotient (* this 100) tot) "% ")) | |
170 | ||
171 | ;--- cutatblank :: cut off a string at the first blank | |
172 | ; | |
173 | (defun cutatblank (str) | |
174 | (do ((i 1 (1+ i))) | |
175 | ((> i 50) str) | |
176 | (If (= (substringn str i 0) #\sp) | |
177 | then (return (substring str 1 i))))) | |
178 | ||
179 | ||
180 | ;--- Pfuncall-evalhook* :: common code to execute when function called. | |
181 | ; | |
182 | ; this function is called whenever a funcallhook or evalhook is taken. | |
183 | ; arguments are the form being evaluated and the type of the form | |
184 | ; which is either eval or funcall. The difference is that a funcall's | |
185 | ; arguments are already evaluated. This makes no difference to us | |
186 | ; but it will effect how the instruction is restarted. | |
187 | ; | |
188 | (defun Pfuncall-evalhook* (form type) | |
189 | (let (name rcd (Pcaller Pcaller)) | |
190 | (If (and (dtpr form) (symbolp (setq name (car form)))) | |
191 | then (If (setq rcd (get name Pcalledby)) | |
192 | then (let ((rent (assq Pcaller rcd))) | |
193 | (If rent | |
194 | then (rplacd rent (1+ (cdr rent))) | |
195 | else (putprop name | |
196 | (cons (cons Pcaller 1) | |
197 | rcd) | |
198 | Pcalledby))) | |
199 | else ; function hasn't been called before, set up a | |
200 | ; record and add its name to the function list | |
201 | (putprop name (ncons (cons Pcaller 1)) Pcalledby) | |
202 | (setq Pfcns (cons name Pfcns))) | |
203 | (setq Pcaller name)) | |
204 | ; now continue executing the function | |
205 | (Pcontinue-evaluation form type))) | |
206 | ||
207 | ||
208 | ||
209 | ||
210 | ;; the functions below are taken from /usr/lib/lisp/step.l and modified | |
211 | ; slightly (addition of P to name) | |
212 | ||
213 | ;--- Pfuncallhook* | |
214 | ; | |
215 | ; automatically called when a funcall is done and funcallhook*'s | |
216 | ; value is the name of this function (Pfuncallhook*). When this is | |
217 | ; called, a function with n-1 args is being funcalled, the args | |
218 | ; to the function are (arg 1) through (arg (sub1 n)), the name of | |
219 | ; the function is (arg n) | |
220 | ; | |
221 | (defun Pfuncallhook* n | |
222 | (let ((name (arg n)) | |
223 | (args (listify (sub1 n)))) | |
224 | (Pfuncall-evalhook* (cons name args) 'funcall))) | |
225 | ||
226 | ;--- Pevalhook* | |
227 | ; | |
228 | ; called whenever an eval is done and evalhook*'s value is the | |
229 | ; name of this function (Pevalhook*). arg is the thing being | |
230 | ; evaluated. | |
231 | ; | |
232 | (defun Pevalhook* (arg) | |
233 | (Pfuncall-evalhook* arg 'eval)) | |
234 | ||
235 | (defun Pcontinue-evaluation (form type) | |
236 | (cond ((eq type 'eval) (evalhook form 'Pevalhook* 'Pfuncallhook*)) | |
237 | (t (funcallhook form 'Pfuncallhook* 'Pevalhook*)))) |