![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fpMeasures.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / fp|
Return to fpMeasures.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / fp |
1.1 root 1: ; FP interpreter/compiler
2: ; Copyright (c) 1982 Scott B. Baden
3: ; Berkeley, California
4: ; Dynamics Statistics by Dorab Patel (UCLA)
5: ;
6: ; Copyright (c) 1982 Regents of the University of California.
7: ; All rights reserved. The Berkeley software License Agreement
8: ; specifies the terms and conditions for redistribution.
9: ;
10: (setq SCCS-fpMeasures.l "@(#)fpMeasures.l 5.1 (Berkeley) 5/31/85")
11:
12: ; Initialize and update the 'Measures' plist with
13: ; the run-time measurement data
14: ;
15: ; Special symbol 'TracedFns' also manipulated
16: ; It contains the list of currently traced user defined functions.
17: ; The attributes for each functional form and function are:
18:
19: ; times: the total number of times it has been called
20: ; size: the sum of the top-level sizes of the arguments given to it
21: ; funargno: the number of functional arguments to this form
22: ; (in general this is only for construct)
23: ; funargtype: the type and total number of functions of that type
24: ; supplied to this functional form.
25: ; This is an alist ((fntype.times) ...)
26:
27:
28:
29: (include specials.l)
30: (declare (special statport dummy))
31: (declare (localf InitSize InitFunArgTyp
32: InitFunArgNo trace1
33: extractName goodStats
34: untrace1 SendMeasures))
35:
36:
37: ; The following functions are global. i.e. used externally
38: ; startDynStats clrDynStats IncrTimes IncrSize
39: ; IncrFunArgNo IncrFunArgTyp size Trace
40: ; PrintMeasures IncrUDF Untrace stopDynStats
41:
42: ; This is called by the main routine to initialize all the
43: ; measurement stuff
44:
45:
46: (defun clrDynStats nil
47: (dontLoseStats)
48: (initStats))
49:
50:
51: (defun dontLoseStats nil
52: (cond ((goodStats) ; check to see if there are stats to report
53: (patom "output dynamic statistics? ")
54: (let ((response (car (explodec (ratom)))))
55: (If ptport then (msg (P ptport) response))
56:
57: (Tyi)
58: (cond ((eq response 'y)
59: (patom "File: ")
60: (let ((statFile
61: (cond ((eq (tyipeek) #.CR) nil)
62: (t
63: (let ((fl (ratom)))
64: (If ptport then (msg (P ptport) fl))
65: fl)))))
66: (Tyi)
67: (PrintMeasures statFile))))))))
68:
69: (defun initStats nil
70:
71: (InitMeasures
72: `(,@#.dyadFns
73: ,@#.miscFns
74: ,@#.multiAdicFns
75: ,@#.libFns
76: ,@#.funcForms))
77:
78: (InitSize #.multiAdicFns)
79: (InitSize #.funcForms)
80: (InitFunArgNo '(constr$fp))
81:
82: ; included here even though it's not a functional form
83: (InitFunArgTyp '(select$fp))
84:
85: (InitFunArgTyp #.funcForms))
86:
87:
88: ; Makes the symbol 'Measures' have the property indicators
89: ; corresponding to the function names in 'ListOfFns' and the values
90: ; to be ((times.0)).
91:
92: (defun InitMeasures (ListOfFns)
93: (setplist 'Measures
94: (apply 'append
95: (mapcar '(lambda (x) (list x (list (cons 'times 0))))
96: ListOfFns))))
97:
98: (defun goodStats nil
99: (do ((M (plist 'Measures) (cddr M)))
100: ((null M) nil)
101: (cond ((not (zerop (cdr (assoc 'times (cadr M)))))
102: (return t)))))
103:
104:
105: ; This is used to stop the collection of dynamic statistics
106: ; needs to untrace functions if they still are. i.e. do the traced-expr stuff
107: ; note that rds which calls this, also calls PrintMeasures, though
108: ; this may change.
109:
110: (defun stopDynStats nil
111: (cond (TracedFns ; if any fns still being traced
112: (Untrace TracedFns))) ; untrace them
113: (setq DynTraceFlg nil))
114:
115: (defun extractName (fnName)
116: (patom
117: (implode (reverse (cons "'" (cdddr (reverse (explodec (concat "'" fnName)))))))))
118:
119: ; this is the function called by the system function trace to
120: ; enable the tracing of the User Defined Functions specified
121: ; NOTE: successive calls will add to the UDFs to be traced.
122:
123: (defun Trace (arglist)
124: (setq traceport poport)
125: (mapc '(lambda (x)
126: (cond ((memq x TracedFns) ; if already traced
127: (setq arglist
128: (delq x arglist 1)) ; delete from arglist
129: (extractName x) ; and tell the user
130: (patom " is already being traced")
131: (terpr))))
132: arglist)
133: (mapc 'trace1 arglist)) ; set up traced-expr stuff
134:
135: ; This is called by the system function untrace to disable the tracing
136: ; of user defined functions.
137: ; This removes the named user defined function from the list
138: ; of traced functions
139:
140: (defun Untrace (arglist)
141: (mapc '(lambda (x)
142: (cond ((memq x TracedFns) ; if being traced
143: (setq TracedFns (delq x TracedFns)) ; remove
144: (untrace1 x)) ; restore stuff
145: (t (extractName x) ; else complain
146: (patom " is not being traced")
147: (terpr))))
148: arglist))
149:
150: ; This is called by Trace on each individual function that is to
151: ; be traced. It does the manipulation of the traced-expr property
152:
153: (defun trace1 (name)
154: ; actually you should check for getd name returning something decent
155: (let ((zExpr (getd name)))
156: (cond ((null zExpr)
157: (patom "Can't trace the undefined fn ")
158: (extractName name)
159: (patom ".")
160: (terpr))
161:
162: (t
163: (putprop name zExpr 'traced-expr) ; put fn def on traced-expr
164: (setq TracedFns (append1 TracedFns name)) ; update TracedFns
165: (InitUDF name) ; set up the measurement stuff
166: (putd name ; make a new function def
167: `(lambda (x)
168: (prog (tmp)
169: (setq level (1+ level)) ; increment level counter
170: (printLevel)
171: (patom " >Enter> " traceport)
172: (patom (extName ',name) traceport)
173: (patom " [" traceport)
174: (d_isplay x traceport)
175: (patom "]" traceport)
176: (terpri traceport)
177: ; now call the actual function
178: (setq tmp (funcall (get ',name 'traced-expr) x))
179: (printLevel)
180: (patom " <EXIT< " traceport) ; now print epilog
181: (patom (extName ',name) traceport)
182: (patom " " traceport)
183: (d_isplay tmp traceport)
184: (terpri traceport)
185: (return tmp)))))))) ; return the return value
186:
187:
188:
189: (defun extName (fnName)
190: (let ((zzName (reverse (explodec fnName))))
191: (cond ((memq '$ zzName) (implode (reverse (cdr (memq '$ zzName)))))
192: (t (implode (reverse (cdr (memq '_ zzName))))))))
193:
194:
195: (defun printLevel nil
196: (do ((counter 1 (1+ counter)))
197: ((eq counter level) (patom level traceport))
198: (cond ((oddp counter) (patom "|" traceport))
199: (t (patom " " traceport)))))
200:
201: ; This is called by Untrace for each individaul function to be untraced.
202: ; It handles the traced-expr property hassles.
203:
204: (defun untrace1 (name)
205: (let ((tmp (get name 'traced-expr)))
206: (cond ((null tmp) ; if the traced-expr property is unreasonable
207: ; a better check for unreasonableness is needed
208: (extractName name) ; complain
209: (patom " was not traced properly - cant restore")
210: (terpr))
211: (t (putd name tmp) ; else restore and remove the traced-expr
212: (remprop name 'traced-expr)))))
213:
214: ; sz is a function that returns the total number of atoms in its argument
215:
216: (defun sz (x)
217: (cond ((null x) 0)
218: ((atom x) 1)
219: (t (add (size (car x))
220: (size (cdr x))))))
221:
222: ; inc is a macro used by the increment functions
223:
224: (defmacro inc (x)
225: `(rplacd ,x (1+ (cdr ,x))))
226:
227: ; inctimes is a macro used by IncrFunArgNo
228:
229: (defmacro inctimes (x times)
230: `(rplacd ,x (add times (cdr ,x))))
231:
232: ; increment the 'funargno' attribute of the functional form
233:
234: (defun IncrFunArgNo (fform times)
235: (inctimes (sassq 'funargno
236: (get 'Measures fform)
237: '(lambda ()
238: (cprintf "error: %s has no funargno"
239: fform)
240: (terpr)
241: (break)))
242: times))
243:
244: ; increment the 'funargtyp' information of the functional form
245: ; if the particular function/form has never yet been used with his
246: ; functional form, create the entry
247:
248: (defun IncrFunArgTyp (fform funct)
249: (inc (sassoc funct ; get (fn.#oftimes). This has to be sassoc NOT sassq.
250: (cadr (sassq 'funargtyp ; get (funargtyp ...)
251: (get 'Measures fform)
252: '(lambda ()
253: (cprintf "error: %s has no funargtyp"
254: fform)
255: (terpr)
256: (break))))
257: ; 'funargtyp' was there but not the funct
258: ; should return (fn.#oftimes)
259: '(lambda ()
260: (cond ((setq dummy (cadr (assq 'funargtyp
261: (get 'Measures fform))))
262: ; the alist is not empty and we
263: ; know that funct was not there
264: (assq funct
265: (nconc dummy
266: (list (cons funct 0)))))
267: ; the alist is empty, so add the element
268: (t (assq funct
269: (cadr (nconc (assq 'funargtyp
270: (get 'Measures fform))
271: (list (list (cons funct 0))))))))))))
272: ; increment the 'times' attribute of the function
273:
274: (defun IncrTimes (funct)
275: (inc (assq 'times (get 'Measures funct))))
276:
277: ; update the 'avg arg size' attribute of the function
278: ; actually it is the total size. it should be divided by the 'times'
279: ; attribute to get the avg size.
280:
281: (defun IncrSize (funct size)
282: (rplacd (assq 'size (get 'Measures funct))
283: (add (cdr (assq 'size (get 'Measures funct)))
284: size)))
285:
286: ; This adds the given function as a property of Measures and
287: ; initializes it to have the 'times' and 'size' attributes.
288:
289: (defun InitUDF (UDF)
290: (putprop 'Measures '((times . 0) (size . 0)) UDF))
291:
292:
293: ; This increments the times and the size atribute of a UDF, if it exists
294: ; Otherwise, it does nothing.
295:
296: (defun IncrUDF (UDF seq)
297: (cond
298: ((and (memq UDF TracedFns) (get 'Measures UDF)) ;if the UDF is traceable
299: (IncrTimes UDF)
300: (IncrSize UDF (size seq)))))
301:
302: ; This adds the 'size' attribute to the alist corresponding to each
303: ; function in 'FnList' and initializes the value to 0.
304:
305: (defun InitSize (FnList)
306: (mapcar '(lambda (funct) (nconc (get 'Measures funct) (list (cons 'size 0))))
307: FnList))
308:
309: ; This adds the 'funargtyp' (functional argument type) attribute to
310: ; the alist corresponding to each functional form in 'FnFormList' and
311: ; initializes the value to nil.
312:
313: (defun InitFunArgTyp (FnFormList)
314: (mapcar '(lambda (fform)
315: (nconc (get 'Measures fform)
316: (list (list 'funargtyp))))
317: FnFormList))
318:
319: ; This adds the 'funargno' (number of functional args) attribute to
320: ; the alist correphsponding to each functional form in 'FnFormList'
321: ; and initializes the value to 0.
322:
323: (defun InitFunArgNo (FnFormList)
324: (mapcar '(lambda (fform)
325: (nconc (get 'Measures fform)
326: (list (cons 'funargno 0))))
327: FnFormList))
328:
329: ; Prints out the stats to a file
330:
331: (defun PrintMeasures (sFileName)
332: (cond (sFileName
333: (let ((statPort nil))
334: (cond ((setq statPort (outfile sFileName 'append))
335: (SendMeasures statPort) ; write the stuff
336: (terpri statPort)
337: (close statPort))
338: (t (terpr)
339: (patom "Cannot open statFile")
340: (terpr)))))
341: (t (SendMeasures nil))))
342:
343:
344: ; Traverses the Measures structure and prints out the
345: ; info onto 'port'.
346: ; Also removes the attributes from Measures (during traversal)
347:
348: (defun SendMeasures (port)
349: (do ((functlist (plist 'Measures)
350: (cddr functlist)));for each alternate elem in functlist
351: ((null functlist)) ; end when all done
352: (let ((fnStats (cadr functlist)))
353: (cond ((and fnStats (not (zerop (cdr (assoc 'times fnStats)))))
354: (cprintf "%s:" (printName (car functlist)) port)
355: (do ((proplist fnStats (cdr proplist)))
356: ((null proplist))
357: (let ((prop (car proplist))) ; for each prop in proplist
358: (cond ((eq (car prop) 'funargtyp) ; if it is funargtyp
359: (doFuncArg port prop))
360: (t (cprintf " %s" (car prop) port);if not funargtyp
361: (cprintf " %d" (cdr prop) port)))))
362: ; end of function
363: (terpri port)
364: (terpri port)))))); a newline separates functions
365:
366: (defun doFuncArg (port prop)
367: (terpri port)
368: (terpri port)
369: (cprintf " Functional Args" nil port)
370: (terpri port)
371: (cprintf " Name Times" nil port)
372: (terpri port)
373: (do ((funclist (cadr prop) (cdr funclist)))
374: ((null funclist))
375: (cprintf " " nil port)
376: (patom (printName (caar funclist)) port)
377: (cprintf " %d" (cdar funclist) port)
378: (terpri port)))
379:
380: (defun printName (fnName)
381: (let ((zzName (reverse (explodec fnName)))
382: (tName nil))
383: (setq tName (memq '$ zzName))
384: (cond (tName (implode (reverse (cdr tName))))
385: (t
386: (setq tName (memq '_ zzName))
387: (cond (tName (implode (reverse (cdr tName))))
388: ((stringp fnName) (concat '|"| fnName '|"|))
389: (t (put_obj fnName)))))))
390:
391: ; this is the same as the function in fp_main.l except that it takes
392: ; an extra argument which is the port name. it is used for printing
393: ; out a lisp object in the FP form
394:
395: (defun d_isplay (obj port)
396: (cond ((null obj) (patom "<>" port))
397: ((atom obj) (patom obj port))
398: ((listp obj)
399: (patom "<" port)
400: (maplist
401: '(lambda (x)
402: (d_isplay (car x) port)
403: (cond ((not (onep (length x))) (patom " " port)))) obj)
404: (patom ">" port))))
405:
406:
407: (defun measAlph (al seq)
408: (IncrFunArgTyp 'alpha$fp al)
409: (IncrTimes 'alpha$fp)
410: (IncrSize 'alpha$fp (size seq)))
411:
412: (defun measIns (ins seq)
413: (IncrFunArgTyp 'insert$fp ins)
414: (IncrTimes 'insert$fp)
415: (IncrSize 'insert$fp (size seq)))
416:
417: (defun measTi (ains seq)
418: (IncrFunArgTyp 'ti$fp ains)
419: (IncrTimes 'ti$fp)
420: (IncrSize 'ti$fp (size seq)))
421:
422: (defun measSel (sel seq)
423: (IncrFunArgTyp 'select$fp sel)
424: (IncrTimes 'select$fp)
425: (IncrSize 'select$fp (size seq)))
426:
427: (defun measCons (cons seq)
428: (IncrFunArgTyp 'constant$fp cons)
429: (IncrTimes 'constant$fp)
430: (IncrSize 'constant$fp (size seq)))
431:
432: (defun measCond (c1 c2 c3 seq)
433: (IncrFunArgTyp 'condit$fp c1)
434: (IncrFunArgTyp 'condit$fp c2)
435: (IncrFunArgTyp 'condit$fp c3)
436: (IncrTimes 'condit$fp)
437: (IncrSize 'condit$fp (size seq)))
438:
439: (defun measWhile (w1 w2 seq)
440: (IncrFunArgTyp 'while$fp w1)
441: (IncrFunArgTyp 'while$fp w2)
442: (IncrTimes 'while$fp)
443: (IncrSize 'while$fp (size seq)))
444:
445: (defun measComp (cm1 cm2 seq)
446: (IncrFunArgTyp 'compos$fp cm1)
447: (IncrFunArgTyp 'compos$fp cm2)
448: (IncrTimes 'compos$fp)
449: (IncrSize 'compos$fp (size seq)))
450:
451: (defun measConstr (fns seq)
452: (mapcar '(lambda (x) (IncrFunArgTyp 'constr$fp x)) fns)
453: (IncrFunArgNo 'constr$fp (length fns))
454: (IncrTimes 'constr$fp)
455: (IncrSize 'constr$fp (size seq)))
456:
457: ; get the corect name of the functional form
458:
459: (defmacro getFform (xx)
460: `(implode (nreverse `(p f ,@(cdr (nreverse (explodec (cxr 0 ,xx))))))))
461:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.