lisp/obsolete/profile.el

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