; FP interpreter/compiler
; Copyright (c) 1982 Scott B. Baden
; Dynamics Statistics by Dorab Patel (UCLA)
; Copyright (c) 1982 Regents of the University of California.
; All rights reserved. The Berkeley software License Agreement
; specifies the terms and conditions for redistribution.
(setq SCCS-fpMeasures.l "@(#)fpMeasures.l 5.1 (Berkeley) 5/31/85")
; Initialize and update the 'Measures' plist with
; the run-time measurement data
; Special symbol 'TracedFns' also manipulated
; It contains the list of currently traced user defined functions.
; The attributes for each functional form and function are:
; times: the total number of times it has been called
; size: the sum of the top-level sizes of the arguments given to it
; funargno: the number of functional arguments to this form
; (in general this is only for construct)
; funargtype: the type and total number of functions of that type
; supplied to this functional form.
; This is an alist ((fntype.times) ...)
(declare (special statport dummy))
(declare (localf InitSize InitFunArgTyp
; The following functions are global. i.e. used externally
; startDynStats clrDynStats IncrTimes IncrSize
; IncrFunArgNo IncrFunArgTyp size Trace
; PrintMeasures IncrUDF Untrace stopDynStats
; This is called by the main routine to initialize all the
(cond ((goodStats) ; check to see if there are stats to report
(patom "output dynamic statistics? ")
(let ((response (car (explodec (ratom)))))
(If ptport then (msg (P ptport) response))
(cond ((eq (tyipeek) #.CR) nil)
(If ptport then (msg (P ptport) fl))
(PrintMeasures statFile))))))))
(InitSize #.multiAdicFns)
(InitFunArgNo '(constr$fp))
; included here even though it's not a functional form
(InitFunArgTyp '(select$fp))
(InitFunArgTyp #.funcForms))
; Makes the symbol 'Measures' have the property indicators
; corresponding to the function names in 'ListOfFns' and the values
(defun InitMeasures (ListOfFns)
(mapcar '(lambda (x) (list x (list (cons 'times 0))))
(do ((M (plist 'Measures) (cddr M)))
(cond ((not (zerop (cdr (assoc 'times (cadr M)))))
; This is used to stop the collection of dynamic statistics
; needs to untrace functions if they still are. i.e. do the traced-expr stuff
; note that rds which calls this, also calls PrintMeasures, though
(cond (TracedFns ; if any fns still being traced
(Untrace TracedFns))) ; untrace them
(defun extractName (fnName)
(implode (reverse (cons "'" (cdddr (reverse (explodec (concat "'" fnName)))))))))
; this is the function called by the system function trace to
; enable the tracing of the User Defined Functions specified
; NOTE: successive calls will add to the UDFs to be traced.
(cond ((memq x TracedFns) ; if already traced
(delq x arglist 1)) ; delete from arglist
(extractName x) ; and tell the user
(patom " is already being traced")
(mapc 'trace1 arglist)) ; set up traced-expr stuff
; This is called by the system function untrace to disable the tracing
; of user defined functions.
; This removes the named user defined function from the list
(cond ((memq x TracedFns) ; if being traced
(setq TracedFns (delq x TracedFns)) ; remove
(untrace1 x)) ; restore stuff
(t (extractName x) ; else complain
(patom " is not being traced")
; This is called by Trace on each individual function that is to
; be traced. It does the manipulation of the traced-expr property
; actually you should check for getd name returning something decent
(let ((zExpr (getd name)))
(patom "Can't trace the undefined fn ")
(putprop name zExpr 'traced-expr) ; put fn def on traced-expr
(setq TracedFns (append1 TracedFns name)) ; update TracedFns
(InitUDF name) ; set up the measurement stuff
(putd name ; make a new function def
(setq level (1+ level)) ; increment level counter
(patom " >Enter> " traceport)
(patom (extName ',name) traceport)
; now call the actual function
(setq tmp (funcall (get ',name 'traced-expr) x))
(patom " <EXIT< " traceport) ; now print epilog
(patom (extName ',name) traceport)
(return tmp)))))))) ; return the return value
(let ((zzName (reverse (explodec fnName))))
(cond ((memq '$ zzName) (implode (reverse (cdr (memq '$ zzName)))))
(t (implode (reverse (cdr (memq '_ zzName))))))))
(do ((counter 1 (1+ counter)))
((eq counter level) (patom level traceport))
(cond ((oddp counter) (patom "|" traceport))
(t (patom " " traceport)))))
; This is called by Untrace for each individaul function to be untraced.
; It handles the traced-expr property hassles.
(let ((tmp (get name 'traced-expr)))
(cond ((null tmp) ; if the traced-expr property is unreasonable
; a better check for unreasonableness is needed
(extractName name) ; complain
(patom " was not traced properly - cant restore")
(t (putd name tmp) ; else restore and remove the traced-expr
(remprop name 'traced-expr)))))
; sz is a function that returns the total number of atoms in its argument
; inc is a macro used by the increment functions
`(rplacd ,x (1+ (cdr ,x))))
; inctimes is a macro used by IncrFunArgNo
(defmacro inctimes (x times)
`(rplacd ,x (add times (cdr ,x))))
; increment the 'funargno' attribute of the functional form
(defun IncrFunArgNo (fform times)
(inctimes (sassq 'funargno
(cprintf "error: %s has no funargno"
; increment the 'funargtyp' information of the functional form
; if the particular function/form has never yet been used with his
; functional form, create the entry
(defun IncrFunArgTyp (fform funct)
(inc (sassoc funct ; get (fn.#oftimes). This has to be sassoc NOT sassq.
(cadr (sassq 'funargtyp ; get (funargtyp ...)
(cprintf "error: %s has no funargtyp"
; 'funargtyp' was there but not the funct
; should return (fn.#oftimes)
(cond ((setq dummy (cadr (assq 'funargtyp
; the alist is not empty and we
; know that funct was not there
; the alist is empty, so add the element
(cadr (nconc (assq 'funargtyp
(list (list (cons funct 0))))))))))))
; increment the 'times' attribute of the function
(inc (assq 'times (get 'Measures funct))))
; update the 'avg arg size' attribute of the function
; actually it is the total size. it should be divided by the 'times'
; attribute to get the avg size.
(defun IncrSize (funct size)
(rplacd (assq 'size (get 'Measures funct))
(add (cdr (assq 'size (get 'Measures funct)))
; This adds the given function as a property of Measures and
; initializes it to have the 'times' and 'size' attributes.
(putprop 'Measures '((times . 0) (size . 0)) UDF))
; This increments the times and the size atribute of a UDF, if it exists
; Otherwise, it does nothing.
((and (memq UDF TracedFns) (get 'Measures UDF)) ;if the UDF is traceable
(IncrSize UDF (size seq)))))
; This adds the 'size' attribute to the alist corresponding to each
; function in 'FnList' and initializes the value to 0.
(mapcar '(lambda (funct) (nconc (get 'Measures funct) (list (cons 'size 0))))
; This adds the 'funargtyp' (functional argument type) attribute to
; the alist corresponding to each functional form in 'FnFormList' and
; initializes the value to nil.
(defun InitFunArgTyp (FnFormList)
(nconc (get 'Measures fform)
(list (list 'funargtyp))))
; This adds the 'funargno' (number of functional args) attribute to
; the alist correphsponding to each functional form in 'FnFormList'
; and initializes the value to 0.
(defun InitFunArgNo (FnFormList)
(nconc (get 'Measures fform)
(list (cons 'funargno 0))))
; Prints out the stats to a file
(defun PrintMeasures (sFileName)
(cond ((setq statPort (outfile sFileName 'append))
(SendMeasures statPort) ; write the stuff
(patom "Cannot open statFile")
; Traverses the Measures structure and prints out the
; Also removes the attributes from Measures (during traversal)
(defun SendMeasures (port)
(do ((functlist (plist 'Measures)
(cddr functlist)));for each alternate elem in functlist
((null functlist)) ; end when all done
(let ((fnStats (cadr functlist)))
(cond ((and fnStats (not (zerop (cdr (assoc 'times fnStats)))))
(cprintf "%s:" (printName (car functlist)) port)
(do ((proplist fnStats (cdr proplist)))
(let ((prop (car proplist))) ; for each prop in proplist
(cond ((eq (car prop) 'funargtyp) ; if it is funargtyp
(t (cprintf " %s" (car prop) port);if not funargtyp
(cprintf " %d" (cdr prop) port)))))
(terpri port)))))); a newline separates functions
(defun doFuncArg (port prop)
(cprintf " Functional Args" nil port)
(cprintf " Name Times" nil port)
(do ((funclist (cadr prop) (cdr funclist)))
(patom (printName (caar funclist)) port)
(cprintf " %d" (cdar funclist) port)
(defun printName (fnName)
(let ((zzName (reverse (explodec fnName)))
(setq tName (memq '$ zzName))
(cond (tName (implode (reverse (cdr tName))))
(setq tName (memq '_ zzName))
(cond (tName (implode (reverse (cdr tName))))
((stringp fnName) (concat '|"| fnName '|"|))
(t (put_obj fnName)))))))
; this is the same as the function in fp_main.l except that it takes
; an extra argument which is the port name. it is used for printing
; out a lisp object in the FP form
(defun d_isplay (obj port)
(cond ((null obj) (patom "<>" port))
((atom obj) (patom obj port))
(cond ((not (onep (length x))) (patom " " port)))) obj)
(IncrFunArgTyp 'alpha$fp al)
(IncrSize 'alpha$fp (size seq)))
(IncrFunArgTyp 'insert$fp ins)
(IncrSize 'insert$fp (size seq)))
(IncrFunArgTyp 'ti$fp ains)
(IncrSize 'ti$fp (size seq)))
(IncrFunArgTyp 'select$fp sel)
(IncrSize 'select$fp (size seq)))
(defun measCons (cons seq)
(IncrFunArgTyp 'constant$fp cons)
(IncrSize 'constant$fp (size seq)))
(defun measCond (c1 c2 c3 seq)
(IncrFunArgTyp 'condit$fp c1)
(IncrFunArgTyp 'condit$fp c2)
(IncrFunArgTyp 'condit$fp c3)
(IncrSize 'condit$fp (size seq)))
(defun measWhile (w1 w2 seq)
(IncrFunArgTyp 'while$fp w1)
(IncrFunArgTyp 'while$fp w2)
(IncrSize 'while$fp (size seq)))
(defun measComp (cm1 cm2 seq)
(IncrFunArgTyp 'compos$fp cm1)
(IncrFunArgTyp 'compos$fp cm2)
(IncrSize 'compos$fp (size seq)))
(defun measConstr (fns seq)
(mapcar '(lambda (x) (IncrFunArgTyp 'constr$fp x)) fns)
(IncrFunArgNo 'constr$fp (length fns))
(IncrSize 'constr$fp (size seq)))
; get the corect name of the functional form
`(implode (nreverse `(p f ,@(cdr (nreverse (explodec (cxr 0 ,xx))))))))