"$Header: /usr/lib/lisp/RCS/prof.l,v 1.2 83/03/27 18:09:22 jkf Exp $")
;; dynamic profiler for lisp -[Tue Mar 8 08:15:47 1983 by jkf]-
;; -> (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
;; 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
;; 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
(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
(setq evalhook 'Pevalhook* funcallhook 'Pfuncallhook*)
(msg "profiling beginning" N)
;--- prof-end :: turn off profiling and generate result list.
(setq evalhook nil funcallhook 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 ((called (get fcn Pcalledby) (cdr 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))
(cons (cons fcn (cdar called))
(get (caar called) 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
; 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
((null xx)(setq Profreport (cons Ptotcalls rep)))
(setq rep (cons (list (car xx)
(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))
then (msg "[prof-end]" N)
(let ((totcalls (car Profreport))
(cond (file-p (setq poport (outfile filename))))
(do ((xx (cdr Profreport) (cdr xx))
(name ) (info) (calledby) (calls) (callcnt))
(pctprint callcnt totcalls)
(If info then (msg " - " (cutatblank (cadr info))))
then (msg "Called by:" N)
(do ((yy (sort calledby 'lesscdr) (cdr yy)))
(msg " " (cdar yy) " :: " (caar yy) N)))
(do ((yy (sort calls 'lesscdr) (cdr yy)))
(msg " " (cdar yy) " :: " (caar yy) N)))
(cond (file-p (close poport)))
;--- 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.
(let ((xc (get x Pcallcnt))
;--- lesscdr :: sort by decreasing cdr's
;--- 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
(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)))
then (rplacd rent (1+ (cdr rent)))
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)))
; 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)
; 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)
(args (listify (sub1 n))))
(Pfuncall-evalhook* (cons name args) 'funcall)))
; called whenever an eval is done and evalhook*'s value is the
; name of this function (Pevalhook*). arg is the thing being
(Pfuncall-evalhook* arg 'eval))
(defun Pcontinue-evaluation (form type)
(cond ((eq type 'eval) (evalhook form 'Pevalhook* 'Pfuncallhook*))
(t (funcallhook form 'Pfuncallhook* 'Pevalhook*))))