/[emacs]/emacs/lisp/emacs-lisp/elp.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/elp.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.34 by ttn, Sat Aug 6 17:08:59 2005 UTC revision 1.35 by monnier, Mon Nov 28 21:55:15 2005 UTC
# Line 206  This variable is set by the master funct Line 206  This variable is set by the master funct
206    "Master function symbol.")    "Master function symbol.")
207    
208  (defvar elp-not-profilable  (defvar elp-not-profilable
209    '(elp-wrapper elp-elapsed-time error call-interactively apply current-time interactive-p)    ;; First, the functions used inside each instrumented function:
210      '(elp-wrapper called-interactively-p
211        ;; Then the functions used by the above functions.  I used
212        ;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x))
213        ;;                   (aref (symbol-function 'elp-wrapper) 2)))
214        ;; to help me find this list.
215        error call-interactively apply current-time)
216    "List of functions that cannot be profiled.    "List of functions that cannot be profiled.
217  Those functions are used internally by the profiling code and profiling  Those functions are used internally by the profiling code and profiling
218  them would thus lead to infinite recursion.")  them would thus lead to infinite recursion.")
219    
220  (defun elp-not-profilable-p (fun)  (defun elp-profilable-p (fun)
221    (or (memq fun elp-not-profilable)    (and (symbolp fun)
222        (keymapp fun)         (fboundp fun)
223        (condition-case nil         (not (or (memq fun elp-not-profilable)
224            (when (subrp (symbol-function fun))                  (keymapp fun)
225              (eq 'unevalled (cdr (subr-arity (symbol-function fun)))))                  (memq (car-safe (symbol-function fun)) '(autoload macro))
226          (error nil))))                  (condition-case nil
227                        (when (subrp (indirect-function fun))
228                          (eq 'unevalled
229                              (cdr (subr-arity (indirect-function fun)))))
230                      (error nil))))))
231    
232    
233  ;;;###autoload  ;;;###autoload
# Line 237  FUNSYM must be a symbol of a defined fun Line 247  FUNSYM must be a symbol of a defined fun
247    (let* ((funguts (symbol-function funsym))    (let* ((funguts (symbol-function funsym))
248           (infovec (vector 0 0 funguts))           (infovec (vector 0 0 funguts))
249           (newguts '(lambda (&rest args))))           (newguts '(lambda (&rest args))))
     ;; We cannot profile functions used internally during profiling.  
     (when (elp-not-profilable-p funsym)  
       (error "ELP cannot profile the function: %s" funsym))  
250      ;; we cannot profile macros      ;; we cannot profile macros
251      (and (eq (car-safe funguts) 'macro)      (and (eq (car-safe funguts) 'macro)
252           (error "ELP cannot profile macro: %s" funsym))           (error "ELP cannot profile macro: %s" funsym))
# Line 252  FUNSYM must be a symbol of a defined fun Line 259  FUNSYM must be a symbol of a defined fun
259      ;; type functionality (i.e. it shouldn't execute the function).      ;; type functionality (i.e. it shouldn't execute the function).
260      (and (eq (car-safe funguts) 'autoload)      (and (eq (car-safe funguts) 'autoload)
261           (error "ELP cannot profile autoloaded function: %s" funsym))           (error "ELP cannot profile autoloaded function: %s" funsym))
262        ;; We cannot profile functions used internally during profiling.
263        (unless (elp-profilable-p funsym)
264          (error "ELP cannot profile the function: %s" funsym))
265      ;; put rest of newguts together      ;; put rest of newguts together
266      (if (commandp funsym)      (if (commandp funsym)
267          (setq newguts (append newguts '((interactive)))))          (setq newguts (append newguts '((interactive)))))
# Line 344  Use optional LIST if provided instead." Line 354  Use optional LIST if provided instead."
354  For example, to instrument all ELP functions, do the following:  For example, to instrument all ELP functions, do the following:
355    
356      \\[elp-instrument-package] RET elp- RET"      \\[elp-instrument-package] RET elp- RET"
357    (interactive "sPrefix of package to instrument: ")    (interactive
358       (list (completing-read "Prefix of package to instrument: "
359                              obarray 'elp-profilable-p)))
360    (if (zerop (length prefix))    (if (zerop (length prefix))
361        (error "Instrumenting all Emacs functions would render Emacs unusable"))        (error "Instrumenting all Emacs functions would render Emacs unusable"))
362    (elp-instrument-list    (elp-instrument-list
363     (mapcar     (mapcar
364      'intern      'intern
365      (all-completions      (all-completions prefix obarray 'elp-profilable-p))))
      prefix obarray  
      (lambda (sym)  
        (and (fboundp sym)  
             (not (or (memq (car-safe (symbol-function sym)) '(autoload macro))  
                      (elp-not-profilable-p sym)))))))))  
366    
367  (defun elp-restore-list (&optional list)  (defun elp-restore-list (&optional list)
368    "Restore the original definitions for all functions in `elp-function-list'.    "Restore the original definitions for all functions in `elp-function-list'.
# Line 488  original definition, use \\[elp-restore- Line 495  original definition, use \\[elp-restore-
495      ;; check for very large or small numbers      ;; check for very large or small numbers
496      (if (string-match "^\\(.*\\)\\(e[+-].*\\)$" number)      (if (string-match "^\\(.*\\)\\(e[+-].*\\)$" number)
497          (concat (substring          (concat (substring
498                   (substring number (match-beginning 1) (match-end 1))                   (match-string 1 number)
499                   0                   0
500                   (- width (match-end 2) (- (match-beginning 2)) 3))                   (- width (match-end 2) (- (match-beginning 2)) 3))
501                  "..."                  "..."
502                  (substring number (match-beginning 2) (match-end 2)))                  (match-string 2 number))
503        (concat (substring number 0 width)))))        (substring number 0 width))))
504    
505  (defun elp-output-result (resultvec)  (defun elp-output-result (resultvec)
506    ;; output the RESULTVEC into the results buffer. RESULTVEC is a 4 or    ;; output the RESULTVEC into the results buffer. RESULTVEC is a 4 or
# Line 528  original definition, use \\[elp-restore- Line 535  original definition, use \\[elp-restore-
535    
536  (defvar elp-results-symname-map  (defvar elp-results-symname-map
537    (let ((map (make-sparse-keymap)))    (let ((map (make-sparse-keymap)))
538      (define-key map [mouse-2] 'elp-results-jump-to-definition-by-mouse)      (define-key map [mouse-2] 'elp-results-jump-to-definition)
539      (define-key map "\C-m" 'elp-results-jump-to-definition)      (define-key map "\C-m" 'elp-results-jump-to-definition)
540      map)      map)
541    "Keymap used on the function name column." )    "Keymap used on the function name column." )
542    
543  (defun elp-results-jump-to-definition-by-mouse (event)  (defun elp-results-jump-to-definition (&optional event)
   "Jump to the definition of the function under the place specified by EVENT."  
   (interactive "e")  
   (posn-set-point (event-end event))  
   (elp-results-jump-to-definition))  
   
 (defun elp-results-jump-to-definition ()  
544    "Jump to the definition of the function under the point."    "Jump to the definition of the function under the point."
545    (interactive)    (interactive (list last-nonmenu-event))
546      (if event (posn-set-point (event-end event)))
547    (find-function (get-text-property (point) 'elp-symname)))    (find-function (get-text-property (point) 'elp-symname)))
548    
549  (defun elp-output-insert-symname (symname)  (defun elp-output-insert-symname (symname)
# Line 550  original definition, use \\[elp-restore- Line 552  original definition, use \\[elp-restore-
552                        'elp-symname (intern symname)                        'elp-symname (intern symname)
553                        'keymap elp-results-symname-map                        'keymap elp-results-symname-map
554                        'mouse-face 'highlight                        'mouse-face 'highlight
555                        'help-echo (substitute-command-keys "\\{elp-results-symname-map}"))))                        'help-echo "mouse-2 or RET jumps to definition")))
556    
557  ;;;###autoload  ;;;###autoload
558  (defun elp-results ()  (defun elp-results ()
# Line 630  displayed." Line 632  displayed."
632    
633  (provide 'elp)  (provide 'elp)
634    
635  ;;; arch-tag: c4eef311-9b3e-4bb2-8a54-3485d41b4eb1  ;; arch-tag: c4eef311-9b3e-4bb2-8a54-3485d41b4eb1
636  ;;; elp.el ends here  ;;; elp.el ends here

Legend:
Removed from v.1.34  
changed lines
  Added in v.1.35

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26