michel@euteal.uucp (Michel Berkelaar) (03/01/89)
This is a simple profiler for functions for Apollo (LUCID) CommonLisp.
I wrote it for personal usage, but it may be of use to others as well.
I have found it very useful to tune my programs.
Do with it as you please.
If there are other profiling packages around for (LUCID) CommonLisp, and
if somebody has gathered experience with them, I am interested as well.
Gathering memory statistics for specific functions is also something I am
interested in, but do not yet have the tools for. So, please post or mail.
--------- Cut here
;;; This is a simple time profiling package for Apollo (LUCID) CommonLisp
;;; Written by Michel Berkelaar, 1988 (mcvax!euteal!michel)
;;;
;;; It provides the functions and macros
;;; (profile <function-name>) --> to turn on profiling for
;;; function <function-name>
;;; (unprofile {function-name}*) --> to turn off profiling
;;; (show-profiles) --> to print all timing results
;;; (reset-profiles) --> to reset all timing values to 0
;;; (get-profile <function-name>) --> returns timing information
;;; for function <function-name>
;;; (reset-profile <function-name>) --> resets timing information
;;; for function <function-name> to 0
;;;
;;; When profiling is turned on for a function, incremental timing information
;;; is gathered. A function is considered running as long as it is on the
;;; stack. Recursive calls are handled correctly, only the highest level call
;;; adds to the timing.
;;; The overhead is not too big, but a performance decrease is noticable,
;;; especially when profiled functions call each other. It is however very
;;; usefull to get an idea where your program is spending cpu time.
;;; Comments and extensions are welcome. Please email or write to:
;;; Michel Berkelaar
;;; (Email: USA: mcvax!euteal!michel, Europe: michel@euteal)
;;; Eindhoven University of Technology
;;; Dept. of Electrical Engineering
;;; Design Automation Section
;;; P.O. Box 513
;;; NL-5600 MB Eindhoven
(provide 'profile)
(defvar *profiled-funs* nil)
(defmacro profile (function)
"(profile <function-name>)
From now on incremental timing statistics of function <function-name> will
be gathered."
`(if (fboundp (quote ,function))
(progn
(pushnew (quote ,function) *profiled-funs*)
(defadvice (,function profile) (&rest args)
(cond
((get (quote ,function) 'running) ;in recursive call, do not time
(apply-advice-continue args))
(t ;function not yet on stack
(let ((time (get-internal-run-time)))
(setf (get (quote ,function) 'running) t)
(prog1 (apply-advice-continue args)
(setf (get (quote ,function) 'time)
(+ (get (quote ,function) 'time 0)
(- (get-internal-run-time) time)))
(setf (get (quote ,function) 'running) nil)
)
))
)
)
)
;; ELSE
(format t ";;; ~A is not a function, request ignored.~%"
(quote ,function))
)
)
(defmacro unprofile (&rest functions)
"(unprofile {function}*)
Stop profiling functions if specified, or all profiled functions and delete
all timing information."
`(dolist (function (or ,functions *profiled-funs*))
(setq *profiled-funs* (delete function *profiled-funs*))
(remove-advice function 'profile)
(remprop function 'time)
(remprop function 'running)
)
)
(defmacro reset-profile (function)
"(reset-profile <function-name>)
Set timing information of function <function-name> to zero."
`(setf (get (quote ,function) 'time) 0)
)
(defmacro get-profile (function)
"(get-profile <function-name>)
Returns the timing information for function <function-name> in seconds."
`(float (/ (get (quote ,function) 'time) internal-time-units-per-second))
)
(defun show-profiles (&optional (stream *standard-output*))
"(show-profiles [stream])
Print the timing information of all profiled functions to stream, which
defaults to the value of *standard-output*."
(setq *profiled-funs* (sort *profiled-funs*
'(lambda (x y)
(> (get x 'time 0) (get y 'time 0)))))
(dolist (fun *profiled-funs*)
(format stream
"~A: ~F seconds.~%"
fun (float (/ (get fun 'time 0) internal-time-units-per-second)))
)
)
(defun reset-profiles ()
"(reset-profiles)
Reset the timing information of all profiled functions to zero."
(dolist (fun *profiled-funs*)
(setf (get fun 'time) 0)
)
)