code.delx.au - gnu-emacs/blob - lisp/obsolete/profile.el

   1 ;;; profile.el --- Emacs profiler (OBSOLETE; use elp.el instead)
   2
   3 ;; Copyright (C) 1992, 1994, 1998, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Boaz Ben-Zvi <boaz@lcs.mit.edu>
   7 ;; Created: 07 Feb 1992
   8 ;; Version: 1.0
   9 ;; Adapted-By: ESR
  10 ;; Keywords: lisp, tools
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 3, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; This file has been obsolete since Emacs 21.1.
  32
  33 ;; DESCRIPTION:
  34 ;; ------------
  35 ;;   This program can be used to monitor running time performance of Emacs Lisp
  36 ;; functions.  It takes a list of functions and report the real time spent
  37 ;; inside these functions.  (Actually, for each function it reports the amount
  38 ;; of time spent while at least one instance of that function is on the call
  39 ;; stack.  So if profiled function FOO calls profiled function BAR, the time
  40 ;; spent inside BAR is credited to both functions.)
  41
  42 ;; HOW TO USE:
  43 ;; -----------
  44 ;;   Set the variable  profile-functions-list  to the list of functions
  45 ;; (as symbols) You want to profile. Call  M-x  profile-functions to set
  46 ;; this list on and start using your program.  Note that profile-functions
  47 ;; MUST be called AFTER all the functions in profile-functions-list have
  48 ;; been loaded !!   (This call modifies the code of the profiled functions.
  49 ;; Hence if you reload these functions, you need to call  profile-functions
  50 ;; again! ).
  51 ;;   To display the results do  M-x  profile-results .  For example:
  52 ;;-------------------------------------------------------------------
  53 ;;  (setq profile-functions-list '(sokoban-set-mode-line sokoban-load-game
  54 ;;                                sokoban-move-vertical sokoban-move))
  55 ;;  (load "sokoban")
  56 ;;  M-x profile-functions
  57 ;;     ...  I play the sokoban game ..........
  58 ;;  M-x profile-results
  59 ;;
  60 ;;      Function                     Time (Seconds.Useconds)
  61 ;;      ========                     =======================
  62 ;;      sokoban-move                     0.539088
  63 ;;      sokoban-move-vertical            0.410130
  64 ;;      sokoban-load-game                0.453235
  65 ;;      sokoban-set-mode-line            1.949203
  66 ;;-----------------------------------------------------
  67 ;; To clear all the settings to profile use profile-finish.
  68 ;; To set one function at a time (instead of or in addition to setting the
  69 ;; above list and  M-x profile-functions) use M-x profile-a-function.
  70
  71 ;;; Code:
  72
  73 ;;;
  74 ;;;  User modifiable VARIABLES
  75 ;;;
  76
  77 (defvar profile-functions-list nil "*List of functions to profile.")
  78 (defvar profile-buffer "*profile*"
  79   "Name of profile buffer.")
  80 (defvar profile-distinct nil
  81   "If non-nil, each time slice gets credited to at most one function.
  82 \(Namely, the most recent one in the call stack.)  If nil, then the
  83 time reported for a function includes the entire time from beginning
  84 to end, even if it called some other function that was also profiled.")
  85
  86 ;;;
  87 ;;; V A R I A B L E S
  88 ;;;
  89
  90 (defvar profile-time-list nil
  91   "List of cumulative calls and time for each profiled function.
  92 Each element looks like (FUN NCALLS SEC . USEC).")
  93 (defvar profile-init-list nil
  94   "List of entry time for each function.
  95 Both how many times invoked and real time of start.
  96 Each element looks like (FUN DEPTH HISEC LOSEC USEC), where DEPTH is
  97 the current recursion depth, and HISEC, LOSEC, and USEC represent the
  98 starting time of the call (or of the outermost recursion).")
  99 (defvar profile-max-fun-name 0
 100   "Max length of name of any function profiled.")
 101 (defvar profile-call-stack nil
 102   "A list of the profiled functions currently executing.
 103 Used only when profile-distinct is non-nil.")
 104 (defvar profile-last-time nil
 105   "The start time of the current time slice.
 106 Used only when profile-distinct is non-nil.")
 107
 108 (defconst profile-million 1000000)
 109
 110 ;;;
 111 ;;; F U N C T I O N S
 112 ;;;
 113
 114 (defun profile-functions (&optional flist)
 115   "Profile all the functions listed in `profile-functions-list'.
 116 With argument FLIST, use the list FLIST instead."
 117   (interactive "P")
 118   (mapcar 'profile-a-function (or flist profile-functions-list)))
 119
 120 (defun profile-print (entry)
 121   "Print one ENTRY (from `profile-time-list')."
 122   (let* ((calls (car (cdr entry)))
 123          (timec (cdr (cdr entry)))
 124          (avgtime (and (not (zerop calls))
 125                        (/ (+ (car timec)
 126                              (/ (cdr timec) (float profile-million)))
 127                           calls))))
 128     (insert (format (concat "%-"
 129                             (int-to-string profile-max-fun-name)
 130                             "s %7d %10d.%06d")
 131                     (car entry) calls (car timec) (cdr timec))
 132             (if (null avgtime)
 133                 "\n"
 134               (format " %18.6f\n" avgtime)))))
 135
 136 (defun profile-results ()
 137   "Display profiling results in the buffer `*profile*'.
 138 \(The buffer name comes from `profile-buffer'.)"
 139   (interactive)
 140   (switch-to-buffer profile-buffer)
 141   (erase-buffer)
 142   (insert "Function" (make-string (- profile-max-fun-name 6) ? ))
 143   (insert " Calls  Total time (sec)  Avg time per call\n")
 144   (insert (make-string profile-max-fun-name ?=) "  ")
 145   (insert "======  ================  =================\n")
 146   (mapcar 'profile-print profile-time-list))
 147
 148 (defun profile-add-time (dest now prev)
 149   "Add to DEST the difference between timestamps NOW and PREV.
 150 DEST is a pair (SEC . USEC) which is modified in place.
 151 NOW and PREV are triples as returned by `current-time'."
 152   (let ((sec (+ (car dest)
 153                 (* 65536 (- (car now) (car prev)))
 154                 (- (cadr now) (cadr prev))))
 155         (usec (+ (cdr dest)
 156                  (- (car (cddr now)) (car (cddr prev))))))
 157     (if (< usec 0)
 158         (setq sec (1- sec)
 159               usec (+ usec profile-million))
 160       (if (>= usec profile-million)
 161           (setq sec (1+ sec)
 162                 usec (- usec profile-million))))
 163     (setcar dest sec)
 164     (setcdr dest usec)))
 165
 166 (defun profile-function-prolog (fun)
 167   "Mark the beginning of a call to function FUN."
 168   (if profile-distinct
 169       (let ((profile-time (current-time)))
 170         (if profile-call-stack
 171             (profile-add-time (cdr (cdr (assq (car profile-call-stack)
 172                                               profile-time-list)))
 173                               profile-time profile-last-time))
 174         (setq profile-call-stack (cons fun profile-call-stack)
 175               profile-last-time profile-time))
 176     (let ((profile-time (current-time))
 177           (init-time (cdr (assq fun profile-init-list))))
 178       (if (null init-time) (error "Function %s missing from list" fun))
 179       (if (not (zerop (car init-time)));; is it a recursive call ?
 180           (setcar init-time (1+ (car init-time)))
 181         (setcar init-time 1)            ; mark first entry
 182         (setcdr init-time profile-time)))))
 183
 184 (defun profile-function-epilog (fun)
 185   "Mark the end of a call to function FUN."
 186   (if profile-distinct
 187       (let ((profile-time (current-time))
 188             (accum (cdr (assq fun profile-time-list))))
 189         (setcar accum (1+ (car accum)))
 190         (profile-add-time (cdr accum) profile-time profile-last-time)
 191         (setq profile-call-stack (cdr profile-call-stack)
 192               profile-last-time profile-time))
 193     (let ((profile-time (current-time))
 194           (init-time (cdr (assq fun profile-init-list)))
 195           (accum (cdr (assq fun profile-time-list))))
 196       (if (or (null init-time)
 197               (null accum))
 198           (error "Function %s missing from list" fun))
 199       (setcar init-time (1- (car init-time))) ; pop one level in recursion
 200       ;; Update only if we've finished the outermost recursive call
 201       (when (zerop (car init-time))
 202         (setcar accum (1+ (car accum)))
 203         (profile-add-time (cdr accum) profile-time (cdr init-time))))))
 204
 205 (defun profile-convert-byte-code (function)
 206   (let ((defn (symbol-function function)))
 207     (if (byte-code-function-p defn)
 208         ;; It is a compiled code object.
 209         (let* ((contents (append defn nil))
 210                (body
 211                 (list (list 'byte-code (nth 1 contents)
 212                             (nth 2 contents) (nth 3 contents)))))
 213           (if (nthcdr 5 contents)
 214               (setq body (cons (list 'interactive (nth 5 contents)) body)))
 215           (if (nth 4 contents)
 216               ;; Use `documentation' here, to get the actual string,
 217               ;; in case the compiled function has a reference
 218               ;; to the .elc file.
 219               (setq body (cons (documentation function) body)))
 220           (fset function (cons 'lambda (cons (car contents) body)))))))
 221
 222 (defun profile-a-function (fun)
 223   "Profile the function FUN."
 224   (interactive "aFunction to profile: ")
 225   (let ((def (symbol-function fun)))
 226     (when (eq (car-safe def) 'autoload)
 227       (load (car (cdr def)))
 228       (setq def (symbol-function fun)))
 229     (fetch-bytecode def))
 230   (profile-convert-byte-code fun)
 231   (let ((def (symbol-function fun)) (funlen (length (symbol-name fun))))
 232     (or (eq (car def) 'lambda)
 233         (error "To profile: %s must be a user-defined function" fun))
 234     (setq profile-time-list             ; add a new entry
 235           (cons (cons fun (cons 0 (cons 0 0))) profile-time-list))
 236     (setq profile-init-list             ; add a new entry
 237           (cons (cons fun (cons 0 nil)) profile-init-list))
 238     (if (< profile-max-fun-name funlen) (setq profile-max-fun-name funlen))
 239     (fset fun (profile-fix-fun fun def))))
 240
 241 (defun profile-fix-fun (fun def)
 242   "Take function FUN and return it fixed for profiling.
 243 DEF is (symbol-function FUN)."
 244   (if (< (length def) 3)
 245       def               ; nothing to change
 246     (let ((prefix (list (car def) (car (cdr def))))
 247           (suffix (cdr (cdr def))))
 248       ;; Skip the doc string, if there is a string
 249       ;; which serves only as a doc string,
 250       ;; and put it in PREFIX.
 251       (if (and (stringp (car suffix)) (cdr suffix))
 252           (setq prefix (nconc prefix (list (car suffix)))
 253                 suffix (cdr suffix)))
 254       ;; Check for an interactive spec.
 255       ;; If found, put it into PREFIX and skip it.
 256       (if (and (listp (car suffix))
 257                (eq (car (car suffix)) 'interactive))
 258           (setq prefix (nconc prefix (list (car suffix)))
 259                 suffix (cdr suffix)))
 260       (if (eq (car-safe (car suffix)) 'profile-function-prolog)
 261           def                           ; already profiled
 262         ;; Prepare new function definition.
 263         ;; If you change this structure, also change profile-restore-fun.
 264         (nconc prefix
 265                (list (list 'profile-function-prolog
 266                            (list 'quote fun))
 267                      (list 'unwind-protect
 268                            (cons 'progn suffix)
 269                            (list 'profile-function-epilog
 270                                  (list 'quote fun)))))))))
 271
 272 (defun profile-restore-fun (fun)
 273   "Restore profiled function FUN to its original state."
 274   (let ((def (symbol-function fun)) body index)
 275     ;; move index beyond header
 276     (setq index (cdr-safe def))
 277     (if (stringp (car (cdr index)))
 278         (setq index (cdr index)))
 279     (if (eq (car-safe (car (cdr index))) 'interactive)
 280         (setq index (cdr index)))
 281     (if (eq (car-safe (car (cdr index))) 'profile-function-prolog)
 282         (setcdr index (cdr (car (cdr (car (cdr (cdr index))))))))))
 283
 284 (defun profile-finish ()
 285   "Stop profiling functions.  Clear all the settings."
 286   (interactive)
 287   (while profile-time-list
 288     (profile-restore-fun (car (car profile-time-list)))
 289     (setq profile-time-list (cdr profile-time-list)))
 290   (setq profile-max-fun-name 0)
 291   (setq profile-init-list nil))
 292
 293 (provide 'profile)
 294
 295 ;; arch-tag: 816f97e8-efff-4da2-9a95-7bc392f58b19
 296 ;;; profile.el ends here