Return to fpMeasures.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / fp

Annotation of 42BSD/ucb/fp/fpMeasures.l, revision 1.1

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.