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