4.3BSD/usr/lib/lisp/prof.l
(setq rcs-prof-
"$Header: /usr/lib/lisp/RCS/prof.l,v 1.2 83/03/27 18:09:22 jkf Exp $")
;; prof
;; dynamic profiler for lisp -[Tue Mar 8 08:15:47 1983 by jkf]-
;;
;; use:
;; -> (load 'prof) ;may not be necessary if autoloading is set up
;; -> (prof-start) ; start the profiling
;; ... do what ever you want here, but don't do a (reset) since
;; that turns off profiling
;; -> (prof-end) ; type this when you are finished
;; -> (prof-report) ; then type this, it will list each funtion
;; ; that was called, who called this function
;; ; and who this function calls.
;;
;; prof uses the evalhook/funcallhook mechanism to get control everytime
;; a function is called. When it gets control, it knows what function
;; is doing the calling (via the Pcaller special variable) and what
;; function is being called. It maintains a running count for each
;; function of the functions which call it and the number of time they
;; do the calling.
;;
;; When prof-end is called, the profiling is turned off and the
;; records kept are inverted, that is for each function it is calculated
;; how many times it calls other functions. A list describing the results
;; is created and assigned to Profreport . When prof-report is called,
;; this record (value of Profreport) is printed in a nice human
;; readable way.
;;
;; multiple profiling runs can be made one after the other and all
;; counts will revert to zero.
;;
(declare (special Pcalledby Pcalls Pfcns Pcaller evalhook funcallhook
Profreport Ptotcalls Pcallcnt Profile-in-progress))
;--- prof-start :: start profiling
;
;
(defun prof-start nil
(setq Pcalledby (gensym) ; plist tag for who calls us
Pcalls (gensym) ; plist tag for who we call
Pfcns (list '<top-lev>) ; list of all functions encountered
Pcaller '<top-lev> ; function being evaluated
Pcallcnt (gensym) ; plist tag for tot number of times called
Ptotcalls 0 ; total number of function calls
Profile-in-progress t) ; indicate we are begin done
(sstatus translink nil)
(setq evalhook 'Pevalhook* funcallhook 'Pfuncallhook*)
(*rset t)
(msg "profiling beginning" N)
(sstatus evalhook t)
t)
;--- prof-end :: turn off profiling and generate result list.
;
(defun prof-end nil
; turn off profiling
(sstatus evalhook nil)
(setq evalhook nil funcallhook nil)
(*rset nil)
(setq Profile-in-progress nil)
(msg (length Pfcns) " different functions called" N)
; generate a profile report
; we already know for each function, who calls that function, now
; we want to figure out who each function calls
(do ((xx Pfcns (cdr xx))
(fcn))
((null xx))
(setq fcn (car xx))
(do ((called (get fcn Pcalledby) (cdr called))
(callcnt 0))
((null called)
; save total number of times this function was called
(putprop fcn callcnt Pcallcnt)
(setq Ptotcalls (+ callcnt Ptotcalls)))
; keep count of the number of time we've been called
(setq callcnt (+ (cdar called) callcnt))
; update data on caller.
(putprop (caar called)
(cons (cons fcn (cdar called))
(get (caar called) Pcalls))
Pcalls)))
(msg Ptotcalls " function calls made" N)
; sort by total calls to function
(setq Pfcns (sort Pfcns 'totcallsort))
; generate report list, really a list of lists each one with this
; form:
; function-name info who-called-it number-of-times-called who-it-called
;
; the car of the report form is the total number of function calls made
(do ((rep nil)
(xx Pfcns (cdr xx)))
((null xx)(setq Profreport (cons Ptotcalls rep)))
(setq rep (cons (list (car xx)
(get (car xx) 'fcn-info)
(get (car xx) Pcalledby)
(get (car xx) Pcallcnt)
(get (car xx) Pcalls))
rep)))
'done)
(declare (special poport))
;--- prof-report :: generate a human readable version of prof report
; input: Profreport (global) : variable set by (prof-end)
;
(defun prof-report (&optional (filename nil file-p))
(if Profile-in-progress
then (msg "[prof-end]" N)
(prof-end))
(let ((totcalls (car Profreport))
(poport poport))
(cond (file-p (setq poport (outfile filename))))
(do ((xx (cdr Profreport) (cdr xx))
(name ) (info) (calledby) (calls) (callcnt))
((null xx))
(setq name (caar xx)
info (cadar xx)
calledby (caddar xx)
callcnt (cadddar xx)
calls (caddddar xx))
(msg ":: " name " ")
(pctprint callcnt totcalls)
(If info then (msg " - " (cutatblank (cadr info))))
(msg N)
(If calledby
then (msg "Called by:" N)
(do ((yy (sort calledby 'lesscdr) (cdr yy)))
((null yy))
(msg " " (cdar yy) " :: " (caar yy) N)))
(If calls
then (msg " Calls: " N)
(do ((yy (sort calls 'lesscdr) (cdr yy)))
((null yy))
(msg " " (cdar yy) " :: " (caar yy) N)))
(msg N N))
(cond (file-p (close poport)))
nil))
;--- totcallsort :: sort by number of calls and then alphabetically
;
; this is the predicate used when sorting the list of functions
; called during the profiling run.
;
(defun totcallsort (x y)
(let ((xc (get x Pcallcnt))
(yc (get y Pcallcnt)))
(If (< xc yc)
thenret
elseif (= xc yc)
then (alphalessp x y)
else nil)))
;--- lesscdr :: sort by decreasing cdr's
;
(defun lesscdr (x y)
(> (cdr x) (cdr y)))
;--- pctprint :: print fraction and then percentage
;
(defun pctprint (this tot)
(msg this "/" tot " " (quotient (* this 100) tot) "% "))
;--- cutatblank :: cut off a string at the first blank
;
(defun cutatblank (str)
(do ((i 1 (1+ i)))
((> i 50) str)
(If (= (substringn str i 0) #\sp)
then (return (substring str 1 i)))))
;--- Pfuncall-evalhook* :: common code to execute when function called.
;
; this function is called whenever a funcallhook or evalhook is taken.
; arguments are the form being evaluated and the type of the form
; which is either eval or funcall. The difference is that a funcall's
; arguments are already evaluated. This makes no difference to us
; but it will effect how the instruction is restarted.
;
(defun Pfuncall-evalhook* (form type)
(let (name rcd (Pcaller Pcaller))
(If (and (dtpr form) (symbolp (setq name (car form))))
then (If (setq rcd (get name Pcalledby))
then (let ((rent (assq Pcaller rcd)))
(If rent
then (rplacd rent (1+ (cdr rent)))
else (putprop name
(cons (cons Pcaller 1)
rcd)
Pcalledby)))
else ; function hasn't been called before, set up a
; record and add its name to the function list
(putprop name (ncons (cons Pcaller 1)) Pcalledby)
(setq Pfcns (cons name Pfcns)))
(setq Pcaller name))
; now continue executing the function
(Pcontinue-evaluation form type)))
;; the functions below are taken from /usr/lib/lisp/step.l and modified
; slightly (addition of P to name)
;--- Pfuncallhook*
;
; automatically called when a funcall is done and funcallhook*'s
; value is the name of this function (Pfuncallhook*). When this is
; called, a function with n-1 args is being funcalled, the args
; to the function are (arg 1) through (arg (sub1 n)), the name of
; the function is (arg n)
;
(defun Pfuncallhook* n
(let ((name (arg n))
(args (listify (sub1 n))))
(Pfuncall-evalhook* (cons name args) 'funcall)))
;--- Pevalhook*
;
; called whenever an eval is done and evalhook*'s value is the
; name of this function (Pevalhook*). arg is the thing being
; evaluated.
;
(defun Pevalhook* (arg)
(Pfuncall-evalhook* arg 'eval))
(defun Pcontinue-evaluation (form type)
(cond ((eq type 'eval) (evalhook form 'Pevalhook* 'Pfuncallhook*))
(t (funcallhook form 'Pfuncallhook* 'Pevalhook*))))