Commit 231d8498 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* lisp/emacs-lisp/nadvice.el: New package.

* lisp/subr.el (special-form-p): New function.
* lisp/emacs-lisp/elp.el: Use lexical-binding and advice-add.
(elp-all-instrumented-list): Remove var.
(elp-not-profilable): Remove elp-wrapper.
(elp-profilable-p): Use autoloadp and special-form-p.
(elp--advice-name): New const.
(elp-instrument-function): Use advice-add.
(elp--instrumented-p): New predicate.
(elp-restore-function): Use advice-remove.
(elp-restore-all, elp-reset-all): Use mapatoms.
(elp-set-master): Use elp--instrumented-p.
(elp--make-wrapper): Rename from elp-wrapper, return a function
suitable for advice-add.  Use cl-inf.
(elp-results): Use mapatoms+elp--instrumented-p.
* lisp/emacs-lisp/debug.el: Use lexical-binding and advice-add.
(debug-function-list): Remove var.
(debug): Rename arg, and then let-bind it explicitly inside.
(debugger-setup-buffer): Rename arg.
(debugger-setup-buffer): Adjust counts to new debug-on-entry setup.
(debugger-frame-number): Adjust to new debug-on-entry setup.
(debug--implement-debug-on-entry): Rename from
implement-debug-on-entry, add argument.
(debugger-special-form-p): Remove, use special-form-p instead.
(debug-on-entry): Use advice-add.
(debug--function-list): New function.
(cancel-debug-on-entry): Use it, along with advice-remove.
(debug-arglist, debug-convert-byte-code, debug-on-entry-1): Remove.
(debugger-list-functions): Use debug--function-list instead of
debug-function-list.
* lisp/emacs-lisp/advice.el (ad-save-real-definition): Remove, unused.
(ad-special-form-p): Remove, use special-form-p instead.
(ad-set-advice-info): Use add-function and remove-function.
(ad--defalias-fset): Adjust accordingly.
* test/automated/advice-tests.el: New tests.
parent be49ba74
......@@ -27,6 +27,13 @@ so we will look at it and add it to the manual.
* Editing Changes in Emacs 24.4
* Changes in Specialized Modes and Packages in Emacs 24.4
* New Modes and Packages in Emacs 24.4
** New nadvice.el package offering lighter-weight advice facilities.
It is layered as:
- add-function/remove-function which can be used to add/remove code on any
function-carrying place, such as process-filters or `<foo>-function' hooks.
- advice-add/advice-remove to add/remove a piece of advice on a named function,
much like `defadvice' does.
* Incompatible Lisp Changes in Emacs 24.4
** `dolist' in lexical-binding mode does not bind VAR in RESULT any more.
......@@ -35,6 +42,7 @@ spurious warnings about an unused var.
* Lisp changes in Emacs 24.4
** New function special-form-p.
** Docstrings can be made dynamic by adding a `dynamic-docstring-function'
text-property on the first char.
......
2012-11-12 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/nadvice.el: New package.
* subr.el (special-form-p): New function.
* emacs-lisp/elp.el: Use lexical-binding and advice-add.
(elp-all-instrumented-list): Remove var.
(elp-not-profilable): Remove elp-wrapper.
(elp-profilable-p): Use autoloadp and special-form-p.
(elp--advice-name): New const.
(elp-instrument-function): Use advice-add.
(elp--instrumented-p): New predicate.
(elp-restore-function): Use advice-remove.
(elp-restore-all, elp-reset-all): Use mapatoms.
(elp-set-master): Use elp--instrumented-p.
(elp--make-wrapper): Rename from elp-wrapper, return a function
suitable for advice-add. Use cl-inf.
(elp-results): Use mapatoms+elp--instrumented-p.
* emacs-lisp/debug.el: Use lexical-binding and advice-add.
(debug-function-list): Remove var.
(debug): Rename arg, and then let-bind it explicitly inside.
(debugger-setup-buffer): Rename arg.
(debugger-setup-buffer): Adjust counts to new debug-on-entry setup.
(debugger-frame-number): Adjust to new debug-on-entry setup.
(debug--implement-debug-on-entry): Rename from
implement-debug-on-entry, add argument.
(debugger-special-form-p): Remove, use special-form-p instead.
(debug-on-entry): Use advice-add.
(debug--function-list): New function.
(cancel-debug-on-entry): Use it, along with advice-remove.
(debug-arglist, debug-convert-byte-code, debug-on-entry-1): Remove.
(debugger-list-functions): Use debug--function-list instead of
debug-function-list.
* emacs-lisp/advice.el (ad-save-real-definition): Remove, unused.
(ad-special-form-p): Remove, use special-form-p instead.
(ad-set-advice-info): Use add-function and remove-function.
(ad--defalias-fset): Adjust accordingly.
2012-11-10 Glenn Morris <rgm@gnu.org>
* mail/emacsbug.el (report-emacs-bug-tracker-url)
......
......@@ -1776,27 +1776,6 @@ generates a copy of TREE."
(funcall fUnCtIoN tReE))
(t tReE)))
;; @@ Save real definitions of subrs used by Advice:
;; =================================================
;; Advice depends on the real, unmodified functionality of various subrs,
;; we save them here so advised versions will not interfere (eventually,
;; we will save all subrs used in code generated by Advice):
(defmacro ad-save-real-definition (function)
(let ((saved-function (intern (format "ad-real-%s" function))))
;; Make sure the compiler is loaded during macro expansion:
(require 'byte-compile "bytecomp")
`(if (not (fboundp ',saved-function))
(progn (fset ',saved-function (symbol-function ',function))
;; Copy byte-compiler properties:
,@(if (get function 'byte-compile)
`((put ',saved-function 'byte-compile
',(get function 'byte-compile))))
,@(if (get function 'byte-opcode)
`((put ',saved-function 'byte-opcode
',(get function 'byte-opcode))))))))
;; @@ Advice info access fns:
;; ==========================
......@@ -1849,9 +1828,12 @@ On each iteration VAR will be bound to the name of an advised function
(defsubst ad-set-advice-info (function advice-info)
(cond
(advice-info (put function 'defalias-fset-function #'ad--defalias-fset))
(advice-info
(add-function :around (get function 'defalias-fset-function)
#'ad--defalias-fset))
((get function 'defalias-fset-function)
(put function 'defalias-fset-function nil)))
(remove-function (get function 'defalias-fset-function)
#'ad--defalias-fset)))
(put function 'ad-advice-info advice-info))
(defmacro ad-copy-advice-info (function)
......@@ -1974,8 +1956,8 @@ Redefining advices affect the construction of an advised definition."
;; to `ad-activate' by using `ad-with-auto-activation-disabled' where
;; appropriate, especially in a safe version of `fset'.
(defun ad--defalias-fset (function definition)
(fset function definition)
(defun ad--defalias-fset (fsetfun function definition)
(funcall (or fsetfun #'fset) function definition)
(ad-activate-internal function nil))
;; For now define `ad-activate-internal' to the dummy definition:
......@@ -2310,12 +2292,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
"Take a macro function DEFINITION and make a lambda out of it."
`(cdr ,definition))
(defun ad-special-form-p (definition)
"Non-nil if and only if DEFINITION is a special form."
(if (and (symbolp definition) (fboundp definition))
(setq definition (indirect-function definition)))
(and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled)))
(defmacro ad-subr-p (definition)
;;"non-nil if DEFINITION is a subr."
(list 'subrp definition))
......@@ -2415,7 +2391,7 @@ definition (see the code for `documentation')."
(cond
((ad-macro-p definition) 'macro)
((ad-subr-p definition)
(if (ad-special-form-p definition)
(if (special-form-p definition)
'special-form
'subr))
((or (ad-lambda-p definition)
......@@ -2804,7 +2780,7 @@ in any of these classes."
(origname (ad-get-advice-info-field function 'origname))
(orig-interactive-p (commandp origdef))
(orig-subr-p (ad-subr-p origdef))
(orig-special-form-p (ad-special-form-p origdef))
(orig-special-form-p (special-form-p origdef))
(orig-macro-p (ad-macro-p origdef))
;; Construct the individual pieces that we need for assembly:
(orig-arglist (ad-arglist origdef))
......
;;; debug.el --- debuggers and related commands for Emacs
;;; debug.el --- debuggers and related commands for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1985-1986, 1994, 2001-2012 Free Software Foundation, Inc.
......@@ -81,9 +81,6 @@ The value used here is passed to `quit-restore-window'."
:group 'debugger
:version "24.2")
(defvar debug-function-list nil
"List of functions currently set for debug on entry.")
(defvar debugger-step-after-exit nil
"Non-nil means \"single-step\" after the debugger exits.")
......@@ -146,7 +143,7 @@ where CAUSE can be:
;;;###autoload
(setq debugger 'debug)
;;;###autoload
(defun debug (&rest debugger-args)
(defun debug (&rest args)
"Enter debugger. \\<debugger-mode-map>`\\[debugger-continue]' returns from the debugger.
Arguments are mainly for use when this is called from the internals
of the evaluator.
......@@ -165,6 +162,7 @@ first will be printed into the backtrace buffer."
(if (get-buffer "*Backtrace*")
(with-current-buffer (get-buffer "*Backtrace*")
(list major-mode (buffer-string)))))
(debugger-args args)
(debugger-buffer (get-buffer-create "*Backtrace*"))
(debugger-old-buffer (current-buffer))
(debugger-window nil)
......@@ -219,7 +217,7 @@ first will be printed into the backtrace buffer."
(save-excursion
(when (eq (car debugger-args) 'debug)
;; Skip the frames for backtrace-debug, byte-code,
;; and implement-debug-on-entry.
;; debug--implement-debug-on-entry and the advice's `apply'.
(backtrace-debug 4 t)
;; Place an extra debug-on-exit for macro's.
(when (eq 'lambda (car-safe (cadr (backtrace-frame 4))))
......@@ -318,7 +316,7 @@ first will be printed into the backtrace buffer."
(setq debug-on-next-call debugger-step-after-exit)
debugger-value)))
(defun debugger-setup-buffer (debugger-args)
(defun debugger-setup-buffer (args)
"Initialize the `*Backtrace*' buffer for entry to the debugger.
That buffer should be current already."
(setq buffer-read-only nil)
......@@ -334,20 +332,22 @@ That buffer should be current already."
(delete-region (point)
(progn
(search-forward "\n debug(")
(forward-line (if (eq (car debugger-args) 'debug)
2 ; Remove implement-debug-on-entry frame.
(forward-line (if (eq (car args) 'debug)
;; Remove debug--implement-debug-on-entry
;; and the advice's `apply' frame.
3
1))
(point)))
(insert "Debugger entered")
;; lambda is for debug-on-call when a function call is next.
;; debug is for debug-on-entry function called.
(pcase (car debugger-args)
(pcase (car args)
((or `lambda `debug)
(insert "--entering a function:\n"))
;; Exiting a function.
(`exit
(insert "--returning value: ")
(setq debugger-value (nth 1 debugger-args))
(setq debugger-value (nth 1 args))
(prin1 debugger-value (current-buffer))
(insert ?\n)
(delete-char 1)
......@@ -356,7 +356,7 @@ That buffer should be current already."
;; Debugger entered for an error.
(`error
(insert "--Lisp error: ")
(prin1 (nth 1 debugger-args) (current-buffer))
(prin1 (nth 1 args) (current-buffer))
(insert ?\n))
;; debug-on-call, when the next thing is an eval.
(`t
......@@ -364,8 +364,8 @@ That buffer should be current already."
;; User calls debug directly.
(_
(insert ": ")
(prin1 (if (eq (car debugger-args) 'nil)
(cdr debugger-args) debugger-args)
(prin1 (if (eq (car args) 'nil)
(cdr args) args)
(current-buffer))
(insert ?\n)))
;; After any frame that uses eval-buffer,
......@@ -525,9 +525,10 @@ removes itself from that hook."
(count 0))
(while (not (eq (cadr (backtrace-frame count)) 'debug))
(setq count (1+ count)))
;; Skip implement-debug-on-entry frame.
(when (eq 'implement-debug-on-entry (cadr (backtrace-frame (1+ count))))
(setq count (1+ count)))
;; Skip debug--implement-debug-on-entry frame.
(when (eq 'debug--implement-debug-on-entry
(cadr (backtrace-frame (1+ count))))
(setq count (+ 2 count)))
(goto-char (point-min))
(when (looking-at "Debugger entered--\\(Lisp error\\|returning value\\):")
(goto-char (match-end 0))
......@@ -694,10 +695,10 @@ Applies to the frame whose line point is on in the backtrace."
:help "Continue to exit from this frame, with all debug-on-entry suspended"))
(define-key menu-map [deb-cont]
'(menu-item "Continue" debugger-continue
:help "Continue, evaluating this expression without stopping"))
:help "Continue, evaluating this expression without stopping"))
(define-key menu-map [deb-step]
'(menu-item "Step through" debugger-step-through
:help "Proceed, stepping through subexpressions of this expression"))
:help "Proceed, stepping through subexpressions of this expression"))
map))
(put 'debugger-mode 'mode-class 'special)
......@@ -777,7 +778,7 @@ For the cross-reference format, see `help-make-xrefs'."
;; When you change this, you may also need to change the number of
;; frames that the debugger skips.
(defun implement-debug-on-entry ()
(defun debug--implement-debug-on-entry (&rest _ignore)
"Conditionally call the debugger.
A call to this function is inserted by `debug-on-entry' to cause
functions to break on entry."
......@@ -785,12 +786,6 @@ functions to break on entry."
nil
(funcall debugger 'debug)))
(defun debugger-special-form-p (symbol)
"Return whether SYMBOL is a special form."
(and (fboundp symbol)
(subrp (symbol-function symbol))
(eq (cdr (subr-arity (symbol-function symbol))) 'unevalled)))
;;;###autoload
(defun debug-on-entry (function)
"Request FUNCTION to invoke debugger each time it is called.
......@@ -808,7 +803,7 @@ Use \\[cancel-debug-on-entry] to cancel the effect of this command.
Redefining FUNCTION also cancels it."
(interactive
(let ((fn (function-called-at-point)) val)
(when (debugger-special-form-p fn)
(when (special-form-p fn)
(setq fn nil))
(setq val (completing-read
(if fn
......@@ -817,36 +812,21 @@ Redefining FUNCTION also cancels it."
obarray
#'(lambda (symbol)
(and (fboundp symbol)
(not (debugger-special-form-p symbol))))
(not (special-form-p symbol))))
t nil nil (symbol-name fn)))
(list (if (equal val "") fn (intern val)))))
;; FIXME: Use advice.el.
(when (debugger-special-form-p function)
(error "Function %s is a special form" function))
(if (or (symbolp (symbol-function function))
(subrp (symbol-function function)))
;; The function is built-in or aliased to another function.
;; Create a wrapper in which we can add the debug call.
(fset function `(lambda (&rest debug-on-entry-args)
,(interactive-form (symbol-function function))
(apply ',(symbol-function function)
debug-on-entry-args)))
(when (autoloadp (symbol-function function))
;; The function is autoloaded. Load its real definition.
(autoload-do-load (symbol-function function) function))
(when (or (not (consp (symbol-function function)))
(and (eq (car (symbol-function function)) 'macro)
(not (consp (cdr (symbol-function function))))))
;; The function is byte-compiled. Create a wrapper in which
;; we can add the debug call.
(debug-convert-byte-code function)))
(unless (consp (symbol-function function))
(error "Definition of %s is not a list" function))
(fset function (debug-on-entry-1 function t))
(unless (memq function debug-function-list)
(push function debug-function-list))
(advice-add function :before #'debug--implement-debug-on-entry)
function)
(defun debug--function-list ()
"List of functions currently set for debug on entry."
(let ((funs '()))
(mapatoms
(lambda (s)
(when (advice-member-p #'debug--implement-debug-on-entry s)
(push s funs))))
funs))
;;;###autoload
(defun cancel-debug-on-entry (&optional function)
"Undo effect of \\[debug-on-entry] on FUNCTION.
......@@ -857,80 +837,16 @@ To specify a nil argument interactively, exit with an empty minibuffer."
(list (let ((name
(completing-read
"Cancel debug on entry to function (default all functions): "
(mapcar 'symbol-name debug-function-list) nil t)))
(mapcar #'symbol-name (debug--function-list)) nil t)))
(when name
(unless (string= name "")
(intern name))))))
(if (and function
(not (string= function ""))) ; Pre 22.1 compatibility test.
(if function
(progn
(let ((defn (debug-on-entry-1 function nil)))
(condition-case nil
(when (and (equal (nth 1 defn) '(&rest debug-on-entry-args))
(eq (car (nth 3 defn)) 'apply))
;; `defn' is a wrapper introduced in debug-on-entry.
;; Get rid of it since we don't need it any more.
(setq defn (nth 1 (nth 1 (nth 3 defn)))))
(error nil))
(fset function defn))
(setq debug-function-list (delq function debug-function-list))
(advice-remove function #'debug--implement-debug-on-entry)
function)
(message "Cancelling debug-on-entry for all functions")
(mapcar 'cancel-debug-on-entry debug-function-list)))
(defun debug-arglist (definition)
;; FIXME: copied from ad-arglist.
"Return the argument list of DEFINITION."
(require 'help-fns)
(help-function-arglist definition 'preserve-names))
(defun debug-convert-byte-code (function)
(let* ((defn (symbol-function function))
(macro (eq (car-safe defn) 'macro)))
(when macro (setq defn (cdr defn)))
(when (byte-code-function-p defn)
(let* ((args (debug-arglist defn))
(body
`((,(if (memq '&rest args) #'apply #'funcall)
,defn
,@(remq '&rest (remq '&optional args))))))
(if (> (length defn) 5)
;; The mere presence of field 5 is sufficient to make
;; it interactive.
(push `(interactive ,(aref defn 5)) body))
(if (and (> (length defn) 4) (aref defn 4))
;; Use `documentation' here, to get the actual string,
;; in case the compiled function has a reference
;; to the .elc file.
(setq body (cons (documentation function) body)))
(setq defn `(closure (t) ,args ,@body)))
(when macro (setq defn (cons 'macro defn)))
(fset function defn))))
(defun debug-on-entry-1 (function flag)
(let* ((defn (symbol-function function))
(tail defn))
(when (eq (car-safe tail) 'macro)
(setq tail (cdr tail)))
(if (not (memq (car-safe tail) '(closure lambda)))
;; Only signal an error when we try to set debug-on-entry.
;; When we try to clear debug-on-entry, we are now done.
(when flag
(error "%s is not a user-defined Lisp function" function))
(if (eq (car tail) 'closure) (setq tail (cdr tail)))
(setq tail (cdr tail))
;; Skip the docstring.
(when (and (stringp (cadr tail)) (cddr tail))
(setq tail (cdr tail)))
;; Skip the interactive form.
(when (eq 'interactive (car-safe (cadr tail)))
(setq tail (cdr tail)))
(unless (eq flag (equal (cadr tail) '(implement-debug-on-entry)))
;; Add/remove debug statement as needed.
(setcdr tail (if flag
(cons '(implement-debug-on-entry) (cdr tail))
(cddr tail)))))
defn))
(mapcar #'cancel-debug-on-entry (debug--function-list))))
(defun debugger-list-functions ()
"Display a list of all the functions now set to debug on entry."
......@@ -940,17 +856,18 @@ To specify a nil argument interactively, exit with an empty minibuffer."
(called-interactively-p 'interactive))
(with-output-to-temp-buffer (help-buffer)
(with-current-buffer standard-output
(if (null debug-function-list)
(princ "No debug-on-entry functions now\n")
(princ "Functions set to debug on entry:\n\n")
(dolist (fun debug-function-list)
(make-text-button (point) (progn (prin1 fun) (point))
'type 'help-function
'help-args (list fun))
(terpri))
(terpri)
(princ "Note: if you have redefined a function, then it may no longer\n")
(princ "be set to debug on entry, even if it is in the list.")))))
(let ((funs (debug--function-list)))
(if (null funs)
(princ "No debug-on-entry functions now\n")
(princ "Functions set to debug on entry:\n\n")
(dolist (fun funs)
(make-text-button (point) (progn (prin1 fun) (point))
'type 'help-function
'help-args (list fun))
(terpri))
(terpri)
(princ "Note: if you have redefined a function, then it may no longer\n")
(princ "be set to debug on entry, even if it is in the list."))))))
(provide 'debug)
......
;;; elp.el --- Emacs Lisp Profiler
;;; elp.el --- Emacs Lisp Profiler -*- lexical-binding: t -*-
;; Copyright (C) 1994-1995, 1997-1998, 2001-2012
;; Free Software Foundation, Inc.
......@@ -124,6 +124,7 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
;; start of user configuration variables
;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
......@@ -148,9 +149,9 @@ Results are displayed with the `elp-results' command."
"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
`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 your own sort function. It should adhere to the
interface specified by the PREDICATE argument for `sort'.
......@@ -167,7 +168,7 @@ 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))
(const :tag "Show All" nil))
:group 'elp)
(defcustom elp-use-standard-output nil
......@@ -193,9 +194,6 @@ In other words, a new unique buffer is create every time you run
(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.")
......@@ -205,7 +203,7 @@ This variable is set by the master function.")
(defvar elp-not-profilable
;; First, the functions used inside each instrumented function:
'(elp-wrapper called-interactively-p
'(called-interactively-p
;; Then the functions used by the above functions. I used
;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x))
;; (aref (symbol-function 'elp-wrapper) 2)))
......@@ -223,60 +221,21 @@ them would thus lead to infinite recursion.")
(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))))))
(autoloadp (symbol-function fun)) ;FIXME: Why not just load it?
(special-form-p fun)))))
(defconst elp--advice-name 'ELP-instrumentation\ )
;;;###autoload
(defun elp-instrument-function (funsym)
"Instrument FUNSYM for profiling.
FUNSYM must be a symbol of a defined function."
(interactive "aFunction to instrument: ")
;; restore the function. this is necessary to avoid infinite
;; recursion of already instrumented functions (i.e. elp-wrapper
;; calling elp-wrapper ad infinitum). it is better to simply
;; restore the function than to throw an error. this will work
;; properly in the face of eval-defun because if the function was
;; redefined, only the timer info will be nil'd out since
;; elp-restore-function is smart enough not to trash the new
;; definition.
(elp-restore-function funsym)
(let* ((funguts (symbol-function funsym))
(infovec (vector 0 0 funguts))
(newguts '(lambda (&rest args))))
;; we cannot profile macros
(and (eq (car-safe funguts) 'macro)
(error "ELP cannot profile macro: %s" funsym))
;; TBD: at some point it might be better to load the autoloaded
;; function instead of throwing an error. if we do this, then we
;; probably want elp-instrument-package to be updated with the
;; newly loaded list of functions. i'm not sure it's smart to do
;; the autoload here, since that could have side effects, and
;; elp-instrument-function is similar (in my mind) to defun-ish
;; type functionality (i.e. it shouldn't execute the function).
(and (autoloadp funguts)
(error "ELP cannot profile autoloaded function: %s" funsym))
(let* ((infovec (vector 0 0)))
;; We cannot profile functions used internally during profiling.
(unless (elp-profilable-p funsym)
(error "ELP cannot profile the function: %s" funsym))
;; put rest of newguts together
(if (commandp funsym)
(setq newguts (append newguts '((interactive)))))
(setq newguts (append newguts `((elp-wrapper
(quote ,funsym)
,(when (commandp funsym)
'(called-interactively-p 'any))
args))))
;; to record profiling times, we set the symbol's function
;; definition so that it runs the elp-wrapper function with the
;; function symbol as an argument. We place the old function
;; definition on the info vector.
;;
;; The info vector data structure is a 3 element vector. The 0th
;; The info vector data structure is a 2 element vector. The 0th
;; element is the call-count, i.e. the total number of times this
;; function has been entered. This value is bumped up on entry to
;; the function so that non-local exists are still recorded. TBD:
......@@ -285,72 +244,45 @@ FUNSYM must be a symbol of a defined function."
;; The 1st element is the total amount of time in seconds that has
;; been spent inside this function. This number is added to on
;; function exit.
;;
;; The 2nd element is the old function definition list. This gets
;; funcall'd in between start/end time retrievals. I believe that
;; this lets us profile even byte-compiled functions.
;; put the info vector on the property list
;; Put the info vector on the property list.
(put funsym elp-timer-info-property infovec)
;; Set the symbol's new profiling function definition to run
;; elp-wrapper.
(let ((advice-info (get funsym 'ad-advice-info)))
(if advice-info
(progn
;; If function is advised, don't let Advice change
;; its definition from under us during the `fset'.
(put funsym 'ad-advice-info nil)
(fset funsym newguts)
(put funsym 'ad-advice-info advice-info))
(fset funsym newguts)))
;; add this function to the instrumentation list
(unless (memq funsym elp-all-instrumented-list)
(push funsym elp-all-instrumented-list))))
;; ELP wrapper.
(advice-add funsym :around (elp--make-wrapper funsym)
`((name . ,elp--advice-name)))))
(defun elp--instrumented-p (sym)
(advice-member-p elp--advice-name sym))
(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)))
;; delete the function from the all instrumented list
(setq elp-all-instrumented-list
(delq funsym elp-all-instrumented-list))
;; if the function was the master, reset the master
(if (eq funsym elp-master)
(setq elp-master nil
elp-record-p t))