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) 05/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 462