Return to prof.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib

Annotation of 42BSD/ucb/lisp/lisplib/prof.l, revision 1.1

1.1     ! root        1: (setq rcs-prof-
        !             2:    "$Header: /usr/lib/lisp/RCS/prof.l,v 1.2 83/03/27 18:09:22 jkf Exp $")
        !             3: 
        !             4: ;; prof
        !             5: ;; dynamic profiler for lisp   -[Tue Mar  8 08:15:47 1983 by jkf]-
        !             6: ;;
        !             7: ;; use:
        !             8: ;; -> (load 'prof)     ;may not be necessary if autoloading is set up
        !             9: ;; -> (prof-start)     ; start the profiling
        !            10: ;;   ... do what ever you want here, but don't do a (reset) since
        !            11: ;;   that turns off profiling
        !            12: ;; -> (prof-end)       ; type this when you are finished
        !            13: ;; -> (prof-report)    ; then type this, it will list each funtion
        !            14: ;;                     ; that was called, who called this function
        !            15: ;;                     ; and who this function calls.
        !            16: ;;
        !            17: ;; prof uses the evalhook/funcallhook mechanism to get control everytime
        !            18: ;; a function is called.  When it gets control, it knows what function
        !            19: ;; is doing the calling (via the Pcaller special variable) and what
        !            20: ;; function is being called.  It maintains a running count for each
        !            21: ;; function of the functions which call it and the number of time they
        !            22: ;; do the calling.
        !            23: ;;
        !            24: ;; When prof-end is called, the profiling is turned off and the
        !            25: ;; records kept are inverted, that is for each function it is calculated
        !            26: ;; how many times it calls other functions.  A list describing the results
        !            27: ;; is created and assigned to Profreport .  When prof-report is called,
        !            28: ;; this record (value of Profreport) is printed in a nice human
        !            29: ;; readable way.
        !            30: ;;
        !            31: ;; multiple profiling runs can be made one after the other and all
        !            32: ;; counts will revert to zero.
        !            33: ;;
        !            34: 
        !            35: 
        !            36: (declare (special Pcalledby Pcalls Pfcns Pcaller evalhook funcallhook
        !            37:                  Profreport Ptotcalls Pcallcnt Profile-in-progress))
        !            38: 
        !            39: ;--- prof-start :: start profiling
        !            40: ;
        !            41: ;
        !            42: (defun prof-start nil
        !            43:    (setq Pcalledby (gensym)    ; plist tag for who calls us
        !            44:         Pcalls (gensym)        ; plist tag for who we call
        !            45:         Pfcns (list '<top-lev>) ; list of all functions encountered
        !            46:         Pcaller '<top-lev>    ; function being evaluated
        !            47:         Pcallcnt (gensym)      ; plist tag for tot number of times called
        !            48:         Ptotcalls 0            ; total number of function calls
        !            49:         Profile-in-progress t) ; indicate we are begin done
        !            50:    (sstatus translink nil)
        !            51:    (setq evalhook 'Pevalhook* funcallhook 'Pfuncallhook*)
        !            52:    (*rset t)
        !            53:    (msg "profiling beginning" N)
        !            54:    (sstatus evalhook t)
        !            55:    t)
        !            56: 
        !            57: ;--- prof-end :: turn off profiling and generate result list.
        !            58: ;
        !            59: (defun prof-end nil
        !            60:    ; turn off profiling
        !            61:    (sstatus evalhook nil)
        !            62:    (setq evalhook nil funcallhook nil)
        !            63:    (*rset nil)
        !            64:    (setq Profile-in-progress nil)
        !            65:    (msg (length Pfcns) " different functions called" N)
        !            66:    ; generate a profile report
        !            67:    ; we already know for each function, who calls that function, now
        !            68:    ; we want to figure out who each function calls
        !            69:    (do ((xx Pfcns (cdr xx))
        !            70:        (fcn))
        !            71:        ((null xx))
        !            72:        (setq fcn (car xx))
        !            73:        (do ((called (get fcn Pcalledby) (cdr called))
        !            74:            (callcnt 0))
        !            75:           ((null called)
        !            76:            ; save total number of times this function was called
        !            77:            (putprop fcn callcnt Pcallcnt)
        !            78:            (setq Ptotcalls (+ callcnt Ptotcalls)))
        !            79:           ; keep count of the number of time we've been called
        !            80:           (setq callcnt (+ (cdar called) callcnt))
        !            81:           ; update data on caller.
        !            82:           (putprop (caar called)
        !            83:                    (cons (cons fcn (cdar called))
        !            84:                          (get (caar called) Pcalls))
        !            85:                    Pcalls)))
        !            86: 
        !            87:    (msg Ptotcalls " function calls made" N)
        !            88:    
        !            89:    ; sort by total calls to function
        !            90:    (setq Pfcns (sort Pfcns 'totcallsort))
        !            91: 
        !            92:    ; generate report list, really a list of lists each one with this
        !            93:    ; form:
        !            94:    ;    function-name  info who-called-it number-of-times-called who-it-called
        !            95:    ;
        !            96:    ; the car of the report form is the total number of function calls made
        !            97:    (do ((rep nil)
        !            98:        (xx Pfcns (cdr xx)))
        !            99:        ((null xx)(setq Profreport (cons Ptotcalls rep)))
        !           100:        (setq rep (cons (list (car xx)
        !           101:                             (get (car xx) 'fcn-info)
        !           102:                             (get (car xx) Pcalledby)
        !           103:                             (get (car xx) Pcallcnt)
        !           104:                             (get (car xx) Pcalls))
        !           105:                       rep)))
        !           106:    'done)
        !           107: 
        !           108: (declare (special poport))
        !           109: 
        !           110: ;--- prof-report :: generate a human readable version of prof report
        !           111: ; input: Profreport (global) : variable set by (prof-end)
        !           112: ;
        !           113: (defun prof-report (&optional (filename nil file-p))
        !           114:    (if Profile-in-progress
        !           115:       then (msg "[prof-end]" N)
        !           116:           (prof-end))
        !           117:    (let ((totcalls (car Profreport))
        !           118:         (poport poport))
        !           119:       (cond (file-p (setq poport (outfile filename))))
        !           120:       (do ((xx (cdr Profreport) (cdr xx))
        !           121:           (name ) (info) (calledby) (calls) (callcnt))
        !           122:          ((null xx))
        !           123:          (setq name     (caar xx)
        !           124:                info     (cadar xx)
        !           125:                calledby (caddar xx)
        !           126:                callcnt  (cadddar xx)
        !           127:                calls    (caddddar xx))
        !           128:          (msg ":: " name " ")
        !           129:          (pctprint callcnt totcalls)
        !           130:          (If info then (msg " - " (cutatblank (cadr info))))
        !           131:          (msg N)
        !           132:          (If calledby
        !           133:             then (msg "Called by:" N)
        !           134:                  (do ((yy (sort calledby 'lesscdr) (cdr yy)))
        !           135:                      ((null yy))
        !           136:                      (msg "    " (cdar yy) " :: " (caar yy) N)))
        !           137:          (If calls
        !           138:             then (msg " Calls: " N)
        !           139:                  (do ((yy (sort calls 'lesscdr) (cdr yy)))
        !           140:                      ((null yy))
        !           141:                      (msg "    " (cdar yy) " :: " (caar yy) N)))
        !           142:          (msg N N))
        !           143:       (cond (file-p (close poport)))
        !           144:       nil))
        !           145: 
        !           146: 
        !           147: ;--- totcallsort :: sort by number of calls and then alphabetically
        !           148: ;
        !           149: ; this is the predicate used when sorting the list of functions
        !           150: ; called during the profiling run.
        !           151: ;
        !           152: (defun totcallsort (x y)
        !           153:    (let ((xc (get x Pcallcnt))
        !           154:         (yc (get y Pcallcnt)))
        !           155:       (If (< xc yc)
        !           156:         thenret
        !           157:        elseif (= xc yc)
        !           158:         then (alphalessp x y)
        !           159:         else nil)))
        !           160: 
        !           161: ;--- lesscdr :: sort by decreasing cdr's
        !           162: ;
        !           163: (defun lesscdr (x y)
        !           164:    (> (cdr x) (cdr y)))
        !           165: 
        !           166: ;--- pctprint :: print fraction and then percentage
        !           167: ;
        !           168: (defun pctprint (this tot)
        !           169:    (msg this "/" tot " " (quotient (* this 100) tot) "% "))
        !           170: 
        !           171: ;--- cutatblank :: cut off a string at the first blank
        !           172: ;
        !           173: (defun cutatblank (str)
        !           174:    (do ((i 1 (1+ i)))
        !           175:        ((> i 50) str)
        !           176:        (If (= (substringn str i 0) #\sp)
        !           177:           then (return (substring str 1 i)))))
        !           178: 
        !           179: 
        !           180: ;--- Pfuncall-evalhook* :: common code to execute when function called.
        !           181: ;
        !           182: ; this function is called whenever a funcallhook or evalhook is taken.
        !           183: ; arguments are the form being evaluated and the type of the form
        !           184: ; which is either eval or funcall.  The difference is that a funcall's
        !           185: ; arguments are already evaluated.  This makes no difference to us
        !           186: ; but it will effect how the instruction is restarted.
        !           187: ;
        !           188: (defun Pfuncall-evalhook* (form type)
        !           189:    (let (name rcd (Pcaller Pcaller))
        !           190:       (If (and (dtpr form) (symbolp (setq name (car form))))
        !           191:         then (If (setq rcd (get name Pcalledby))
        !           192:                 then (let ((rent (assq Pcaller rcd)))
        !           193:                         (If rent
        !           194:                            then (rplacd rent (1+ (cdr rent)))
        !           195:                            else (putprop name
        !           196:                                          (cons (cons Pcaller 1)
        !           197:                                                rcd)
        !           198:                                          Pcalledby)))
        !           199:                 else ; function hasn't been called before, set up a
        !           200:                      ; record and add its name to the function list
        !           201:                      (putprop name (ncons (cons Pcaller 1)) Pcalledby)
        !           202:                      (setq Pfcns (cons name Pfcns)))
        !           203:              (setq Pcaller name))
        !           204:       ; now continue executing the function
        !           205:       (Pcontinue-evaluation form type)))
        !           206: 
        !           207:                              
        !           208: 
        !           209: 
        !           210: ;; the functions below are taken from /usr/lib/lisp/step.l and modified
        !           211: ; slightly (addition of P to name)
        !           212: 
        !           213: ;--- Pfuncallhook* 
        !           214: ;
        !           215: ; automatically called when a funcall is done and funcallhook*'s 
        !           216: ; value is the name of this function (Pfuncallhook*).  When this is
        !           217: ; called, a function with n-1 args is being funcalled, the args
        !           218: ; to the function are (arg 1) through (arg (sub1 n)), the name of
        !           219: ; the function is (arg n)
        !           220: ;
        !           221: (defun Pfuncallhook* n
        !           222:   (let ((name (arg n))
        !           223:        (args (listify (sub1 n))))
        !           224:        (Pfuncall-evalhook* (cons name args) 'funcall)))
        !           225: 
        !           226: ;--- Pevalhook* 
        !           227: ;
        !           228: ; called whenever an eval is done and evalhook*'s value is the 
        !           229: ; name of this function (Pevalhook*).  arg is the thing being
        !           230: ; evaluated.
        !           231: ;
        !           232: (defun Pevalhook* (arg)
        !           233:   (Pfuncall-evalhook* arg 'eval))
        !           234: 
        !           235: (defun Pcontinue-evaluation (form type)
        !           236:   (cond ((eq type 'eval) (evalhook form 'Pevalhook* 'Pfuncallhook*))
        !           237:        (t (funcallhook form 'Pfuncallhook* 'Pevalhook*))))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.