Return to fpMeasures.l CVS log

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

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

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.