(defgroup elp nil
"Emacs Lisp Profiler."
:group 'lisp)
(defcustom elp-function-list nil
"*List of functions to profile.
Used by the command `elp-instrument-list'."
:type '(repeat function)
:group 'elp)
(defcustom elp-reset-after-results t
"*Non-nil means reset all profiling info after results are displayed.
Results are displayed with the `elp-results' command."
:type 'boolean
:group 'elp)
(defcustom elp-sort-by-function 'elp-sort-by-total-time
"*Non-nil specifies elp results sorting function.
These functions are currently available:
elp-sort-by-call-count -- sort by the highest call count
elp-sort-by-total-time -- sort by the highest total time
elp-sort-by-average-time -- sort by the highest average times
You can write you're own sort function. It should adhere to the
interface specified by the PRED argument for the `sort' defun. Each
\"element of LIST\" is really a 4 element vector where element 0 is
the call count, element 1 is the total time spent in the function,
element 2 is the average time spent in the function, and element 3 is
the symbol's name string."
:type 'function
:group 'elp)
(defcustom elp-report-limit 1
"*Prevents some functions from being displayed in the results buffer.
If a number, no function that has been called fewer than that number
of times will be displayed in the output buffer. If nil, all
functions will be displayed."
:type '(choice integer
(const :tag "Show All" nil))
:group 'elp)
(defcustom elp-use-standard-output nil
"*Non-nil says to output to `standard-output' instead of a buffer."
:type 'boolean
:group 'elp)
(defcustom elp-recycle-buffers-p t
"*nil says to not recycle the `elp-results-buffer'.
In other words, a new unique buffer is create every time you run
\\[elp-results]."
:type 'boolean
:group 'elp)
(defvar elp-results-buffer "*ELP Profiling Results*"
"Buffer name for outputting profiling results.")
(defconst elp-timer-info-property 'elp-info
"ELP information property name.")
(defvar elp-all-instrumented-list nil
"List of all functions currently being instrumented.")
(defvar elp-record-p t
"Controls whether functions should record times or not.
This variable is set by the master function.")
(defvar elp-master nil
"Master function symbol.")
(defvar elp-not-profilable
'(elp-wrapper called-interactively-p
error call-interactively apply current-time)
"List of functions that cannot be profiled.
Those functions are used internally by the profiling code and profiling
them would thus lead to infinite recursion.")
(defun elp-profilable-p (fun)
(and (symbolp fun)
(fboundp fun)
(not (or (memq fun elp-not-profilable)
(keymapp fun)
(memq (car-safe (symbol-function fun)) '(autoload macro))
(condition-case nil
(when (subrp (indirect-function fun))
(eq 'unevalled
(cdr (subr-arity (indirect-function fun)))))
(error nil))))))
(defun elp-instrument-function (funsym)
"Instrument FUNSYM for profiling.
FUNSYM must be a symbol of a defined function."
(interactive "aFunction to instrument: ")
(elp-restore-function funsym)
(let* ((funguts (symbol-function funsym))
(infovec (vector 0 0 funguts))
(newguts '(lambda (&rest args))))
(and (eq (car-safe funguts) 'macro)
(error "ELP cannot profile macro: %s" funsym))
(and (eq (car-safe funguts) 'autoload)
(error "ELP cannot profile autoloaded function: %s" funsym))
(unless (elp-profilable-p funsym)
(error "ELP cannot profile the function: %s" funsym))
(if (commandp funsym)
(setq newguts (append newguts '((interactive)))))
(setq newguts (append newguts `((elp-wrapper
(quote ,funsym)
,(when (commandp funsym)
'(called-interactively-p))
args))))
(put funsym elp-timer-info-property infovec)
(let ((advice-info (get funsym 'ad-advice-info)))
(if advice-info
(progn
(put funsym 'ad-advice-info nil)
(fset funsym newguts)
(put funsym 'ad-advice-info advice-info))
(fset funsym newguts)))
(unless (memq funsym elp-all-instrumented-list)
(push funsym elp-all-instrumented-list))))
(defun elp-restore-function (funsym)
"Restore an instrumented function to its original definition.
Argument FUNSYM is the symbol of a defined function."
(interactive "aFunction to restore: ")
(let ((info (get funsym elp-timer-info-property)))
(setq elp-all-instrumented-list
(delq funsym elp-all-instrumented-list))
(if (eq funsym elp-master)
(setq elp-master nil
elp-record-p t))
(put funsym elp-timer-info-property nil)
(and info
(functionp funsym)
(not (byte-code-function-p (symbol-function funsym)))
(assq 'elp-wrapper (symbol-function funsym))
(fset funsym (aref info 2)))))
(defun elp-instrument-list (&optional list)
"Instrument for profiling, all functions in `elp-function-list'.
Use optional LIST if provided instead."
(interactive "PList of functions to instrument: ")
(let ((list (or list elp-function-list)))
(mapcar 'elp-instrument-function list)))
(defun elp-instrument-package (prefix)
"Instrument for profiling, all functions which start with PREFIX.
For example, to instrument all ELP functions, do the following:
\\[elp-instrument-package] RET elp- RET"
(interactive
(list (completing-read "Prefix of package to instrument: "
obarray 'elp-profilable-p)))
(if (zerop (length prefix))
(error "Instrumenting all Emacs functions would render Emacs unusable"))
(elp-instrument-list
(mapcar
'intern
(all-completions prefix obarray 'elp-profilable-p))))
(defun elp-restore-list (&optional list)
"Restore the original definitions for all functions in `elp-function-list'.
Use optional LIST if provided instead."
(interactive "PList of functions to restore: ")
(let ((list (or list elp-function-list)))
(mapcar 'elp-restore-function list)))
(defun elp-restore-all ()
"Restores the original definitions of all functions being profiled."
(interactive)
(elp-restore-list elp-all-instrumented-list))
(defun elp-reset-function (funsym)
"Reset the profiling information for FUNSYM."
(interactive "aFunction to reset: ")
(let ((info (get funsym elp-timer-info-property)))
(or info
(error "%s is not instrumented for profiling" funsym))
(aset info 0 0) (aset info 1 0.0) ))
(defun elp-reset-list (&optional list)
"Reset the profiling information for all functions in `elp-function-list'.
Use optional LIST if provided instead."
(interactive "PList of functions to reset: ")
(let ((list (or list elp-function-list)))
(mapcar 'elp-reset-function list)))
(defun elp-reset-all ()
"Reset the profiling information for all functions being profiled."
(interactive)
(elp-reset-list elp-all-instrumented-list))
(defun elp-set-master (funsym)
"Set the master function for profiling."
(interactive "aMaster function: ")
(setq elp-master funsym
elp-record-p nil)
(or (memq funsym elp-all-instrumented-list)
(elp-instrument-function funsym)))
(defun elp-unset-master ()
"Unsets the master function."
(interactive)
(setq elp-master nil
elp-record-p t))
(defsubst elp-elapsed-time (start end)
(+ (* (- (car end) (car start)) 65536.0)
(- (car (cdr end)) (car (cdr start)))
(/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0)))
(defun elp-wrapper (funsym interactive-p args)
"This function has been instrumented for profiling by the ELP.
ELP is the Emacs Lisp Profiler. To restore the function to its
original definition, use \\[elp-restore-function] or \\[elp-restore-all]."
(if (and elp-master
(eq funsym elp-master))
(setq elp-record-p t))
(let* ((info (get funsym elp-timer-info-property))
(func (aref info 2))
result)
(or func
(error "%s is not instrumented for profiling" funsym))
(if (not elp-record-p)
(setq result
(if interactive-p
(call-interactively func)
(apply func args)))
(let (enter-time exit-time)
(aset info 0 (1+ (aref info 0)))
(if interactive-p
(setq enter-time (current-time)
result (call-interactively func)
exit-time (current-time))
(setq enter-time (current-time)
result (apply func args)
exit-time (current-time)))
(aset info 1 (+ (aref info 1) (elp-elapsed-time enter-time exit-time)))
))
(if (and elp-master
(eq funsym elp-master))
(setq elp-record-p nil))
result))
(defvar elp-field-len nil)
(defvar elp-cc-len nil)
(defvar elp-at-len nil)
(defvar elp-et-len nil)
(defun elp-sort-by-call-count (vec1 vec2)
(>= (aref vec1 0) (aref vec2 0)))
(defun elp-sort-by-total-time (vec1 vec2)
(>= (aref vec1 1) (aref vec2 1)))
(defun elp-sort-by-average-time (vec1 vec2)
(>= (aref vec1 2) (aref vec2 2)))
(defsubst elp-pack-number (number width)
(if (<= (length number) width)
number
(if (string-match "^\\(.*\\)\\(e[+-].*\\)$" number)
(concat (substring
(match-string 1 number)
0
(- width (match-end 2) (- (match-beginning 2)) 3))
"..."
(match-string 2 number))
(substring number 0 width))))
(defun elp-output-result (resultvec)
(let* ((cc (aref resultvec 0))
(tt (aref resultvec 1))
(at (aref resultvec 2))
(symname (aref resultvec 3))
callcnt totaltime avetime)
(setq callcnt (number-to-string cc)
totaltime (number-to-string tt)
avetime (number-to-string at))
(if (and elp-report-limit
(numberp elp-report-limit)
(< cc elp-report-limit))
nil
(elp-output-insert-symname symname)
(insert-char 32 (+ elp-field-len (- (length symname)) 2))
(insert callcnt)
(insert-char 32 (+ elp-cc-len (- (length callcnt)) 2))
(let ((ttstr (elp-pack-number totaltime elp-et-len))
(atstr (elp-pack-number avetime elp-at-len)))
(insert ttstr)
(insert-char 32 (+ elp-et-len (- (length ttstr)) 2))
(insert atstr))
(insert "\n"))))
(defvar elp-results-symname-map
(let ((map (make-sparse-keymap)))
(define-key map [mouse-2] 'elp-results-jump-to-definition)
(define-key map "\C-m" 'elp-results-jump-to-definition)
map)
"Keymap used on the function name column." )
(defun elp-results-jump-to-definition (&optional event)
"Jump to the definition of the function under the point."
(interactive (list last-nonmenu-event))
(if event (posn-set-point (event-end event)))
(find-function (get-text-property (point) 'elp-symname)))
(defun elp-output-insert-symname (symname)
(insert (propertize symname
'elp-symname (intern symname)
'keymap elp-results-symname-map
'mouse-face 'highlight
'help-echo "mouse-2 or RET jumps to definition")))
(defun elp-results ()
"Display current profiling results.
If `elp-reset-after-results' is non-nil, then current profiling
information for all instrumented functions are reset after results are
displayed."
(interactive)
(let ((curbuf (current-buffer))
(resultsbuf (if elp-recycle-buffers-p
(get-buffer-create elp-results-buffer)
(generate-new-buffer elp-results-buffer))))
(set-buffer resultsbuf)
(erase-buffer)
(let* ((longest 0)
(title "Function Name")
(titlelen (length title))
(elp-field-len titlelen)
(cc-header "Call Count")
(elp-cc-len (length cc-header))
(et-header "Elapsed Time")
(elp-et-len (length et-header))
(at-header "Average Time")
(elp-at-len (length at-header))
(resvec
(mapcar
(function
(lambda (funsym)
(let* ((info (get funsym elp-timer-info-property))
(symname (format "%s" funsym))
(cc (aref info 0))
(tt (aref info 1)))
(if (not info)
(insert "No profiling information found for: "
symname)
(setq longest (max longest (length symname)))
(vector cc tt (if (zerop cc)
0.0 (/ (float tt) (float cc)))
symname)))))
elp-all-instrumented-list))
) (insert title)
(if (> longest titlelen)
(progn
(insert-char 32 (- longest titlelen))
(setq elp-field-len longest)))
(insert " " cc-header " " et-header " " at-header "\n")
(insert-char ?= elp-field-len)
(insert " ")
(insert-char ?= elp-cc-len)
(insert " ")
(insert-char ?= elp-et-len)
(insert " ")
(insert-char ?= elp-at-len)
(insert "\n")
(if elp-sort-by-function
(setq resvec (sort resvec elp-sort-by-function)))
(mapcar 'elp-output-result resvec))
(set-buffer curbuf)
(pop-to-buffer resultsbuf)
(if (or elp-use-standard-output noninteractive)
(princ (buffer-substring (point-min) (point-max))))
(and elp-reset-after-results
(elp-reset-all))))
(defun elp-unload-hook ()
(elp-restore-all))
(add-hook 'elp-unload-hook 'elp-unload-hook)
(provide 'elp)