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