![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to prof.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to prof.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 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*))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.