lisp/emacs-lisp/profile.el

   1 ;;; profile.el --- generate run time measurements of Emacs Lisp functions
   2
   3 ;; Copyright (C) 1992, 1994 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. It runs a process with a separate timer program.
  35 ;;   Caveat: the C code in ../lib-src/profile.c requires BSD-compatible
  36 ;; time-of-day functions.  If you're running an AT&T version prior to SVr4,
  37 ;; you may have difficulty getting it to work.  Your X library may supply
  38 ;; the required routines if the standard C library does not.
  39
  40 ;; HOW TO USE:
  41 ;; -----------
  42 ;;   Set the variable  profile-functions-list  to the list of functions
  43 ;; (as symbols) You want to profile. Call  M-x  profile-functions to set
  44 ;; this list on and start using your program.  Note that profile-functions
  45 ;; MUST be called AFTER all the functions in profile-functions-list have
  46 ;; been loaded !!   (This call modifies the code of the profiled functions.
  47 ;; Hence if you reload these functions, you need to call  profile-functions
  48 ;; again! ).
  49 ;;   To display the results do  M-x  profile-results .  For example:
  50 ;;-------------------------------------------------------------------
  51 ;;  (setq profile-functions-list '(sokoban-set-mode-line sokoban-load-game
  52 ;;                                sokoban-move-vertical sokoban-move))
  53 ;;  (load "sokoban")
  54 ;;  M-x profile-functions
  55 ;;     ...  I play the sokoban game ..........
  56 ;;  M-x profile-results
  57 ;;
  58 ;;      Function                     Time (Seconds.Useconds)
  59 ;;      ========                     =======================
  60 ;;      sokoban-move                     0.539088
  61 ;;      sokoban-move-vertical            0.410130
  62 ;;      sokoban-load-game                0.453235
  63 ;;      sokoban-set-mode-line            1.949203
  64 ;;-----------------------------------------------------
  65 ;; To clear all the settings to profile use profile-finish.
  66 ;; To set one function at a time (instead of or in addition to setting the
  67 ;; above list and  M-x profile-functions) use M-x profile-a-function.
  68
  69 ;;; Code:
  70
  71 ;;;
  72 ;;;  User modifiable VARIABLES
  73 ;;;
  74
  75 (defvar profile-functions-list nil "*List of functions to profile.")
  76 (defvar profile-timer-program
  77   (concat exec-directory "profile")
  78   "*Name of the profile timer program.")
  79
  80 ;;;
  81 ;;; V A R I A B L E S
  82 ;;;
  83
  84 (defvar profile-timer-process nil "Process running the timer.")
  85 (defvar profile-time-list nil
  86     "List of cumulative calls and time for each profiled function.")
  87 (defvar profile-init-list nil
  88     "List of entry time for each function.
  89 Both how many times invoked and real time of start.")
  90 (defvar profile-max-fun-name 0 "Max length of name of any function profiled.")
  91 (defvar profile-temp-result- nil "Should NOT be used anywhere else.")
  92 (defvar profile-time (cons 0 0) "Used to return result from a filter.")
  93 (defvar profile-buffer "*profile*" "Name of profile buffer.")
  94
  95 ;;;
  96 ;;; F U N C T I O N S
  97 ;;;
  98
  99 (defun profile-functions (&optional flist)
 100   "Profile all the functions listed in `profile-functions-list'.
 101 With argument FLIST, use the list FLIST instead."
 102   (interactive "P")
 103   (if (null flist) (setq flist profile-functions-list))
 104   (mapcar 'profile-a-function flist))
 105
 106 (defun profile-filter (process input)
 107   "Filter for the timer process.  Sets `profile-time' to the returned time."
 108   (if (zerop (string-match "\\." input))
 109       (error "Bad output from %s" profile-timer-program)
 110     (setcar profile-time
 111             (string-to-int (substring input 0 (match-beginning 0))))
 112     (setcdr profile-time
 113             (string-to-int (substring input (match-end 0))))))
 114
 115
 116 (defun profile-print (entry)
 117   "Print one ENTRY (from `profile-time-list')."
 118   (let* ((calls (car (cdr entry)))
 119          (timec (cdr (cdr entry)))
 120          (time (+ (car timec) (/ (cdr timec) (float profile-million))))
 121          (avgtime 0.0))
 122     (insert (format (concat "%-"
 123                             (int-to-string profile-max-fun-name)
 124                             "s%8d%11d.%06d")
 125                     (car entry) calls (car timec) (cdr timec))
 126             (if (zerop calls)
 127                 "\n"
 128               (format "%12d.%06d\n"
 129                       (truncate (setq avgtime (/ time calls)))
 130                       (truncate (* (- avgtime (ftruncate avgtime))
 131                                    profile-million))))
 132             )))
 133
 134 (defun profile-results ()
 135   "Display profiling results in the buffer `*profile*'.
 136 \(The buffer name comes from `profile-buffer'.)"
 137   (interactive)
 138   (switch-to-buffer profile-buffer)
 139   (erase-buffer)
 140   (insert "Function" (make-string (- profile-max-fun-name 6) ? ))
 141   (insert " Calls  Total time (sec)  Avg time per call\n")
 142   (insert (make-string profile-max-fun-name ?=) "  ")
 143   (insert "======  ================  =================\n")
 144   (mapcar 'profile-print profile-time-list))
 145
 146 (defun profile-reset-timer ()
 147   (process-send-string profile-timer-process "z\n"))
 148
 149 (defun profile-check-zero-init-times (entry)
 150   "If ENTRY has non zero time, give an error."
 151   (let ((time (cdr (cdr entry))))
 152     (if (and (zerop (car time)) (zerop (cdr time))) nil ; OK
 153       (error "Process timer died while making performance profile."))))
 154
 155 (defun profile-get-time ()
 156   "Get time from timer process into `profile-time'."
 157   ;; first time or if process dies
 158   (if (and (processp profile-timer-process)
 159            (eq 'run (process-status profile-timer-process))) nil
 160     (setq profile-timer-process;; [re]start the timer process
 161           (start-process "timer"
 162                          (get-buffer-create profile-buffer)
 163                          profile-timer-program))
 164     (set-process-filter profile-timer-process 'profile-filter)
 165     (process-kill-without-query profile-timer-process)
 166     (profile-reset-timer)
 167     ;; check if timer died during time measurement
 168     (mapcar 'profile-check-zero-init-times profile-init-list))
 169   ;; make timer process return current time
 170   (process-send-string profile-timer-process "p\n")
 171   (accept-process-output))
 172
 173 (defun profile-find-function (fun flist)
 174   "Linear search for FUN in FLIST."
 175   (if (null flist) nil
 176     (if (eq fun (car (car flist))) (cdr (car flist))
 177       (profile-find-function fun (cdr flist)))))
 178
 179 (defun profile-start-function (fun)
 180   "On entry, keep current time for function FUN."
 181   ;; assumes that profile-time contains the current time
 182   (let ((init-time (profile-find-function fun profile-init-list)))
 183     (if (null init-time) (error "Function %s missing from list" fun))
 184     (if (not (zerop (car init-time)));; is it a recursive call ?
 185         (setcar init-time (1+ (car init-time)))
 186       (setcar init-time 1)              ; mark first entry
 187       (setq init-time (cdr init-time))
 188       (setcar init-time (car profile-time))
 189       (setcdr init-time (cdr profile-time)))
 190     ))
 191
 192 (defconst profile-million 1000000)
 193
 194 (defun profile-update-function (fun)
 195   "When the call to the function FUN is finished, add its run time."
 196   ;; assumes that profile-time contains the current time
 197   (let ((init-time (profile-find-function fun profile-init-list))
 198         (accum (profile-find-function fun profile-time-list))
 199         calls time sec usec)
 200     (if (or (null init-time)
 201             (null accum)) (error "Function %s missing from list" fun))
 202     (setq calls (car accum))
 203     (setq time (cdr accum))
 204     (setcar init-time (1- (car init-time))) ; pop one level in recursion
 205     (if (not (zerop (car init-time)))
 206         nil                             ; in some recursion level,
 207                                         ; do not update cumulated time
 208       (setcar accum (1+ calls))
 209       (setq init-time (cdr init-time))
 210       (setq sec (- (car profile-time) (car init-time))
 211             usec (- (cdr profile-time) (cdr init-time)))
 212       (setcar init-time 0)              ;  reset time to check for error
 213       (setcdr init-time 0)              ;  in case timer process dies
 214       (if (>= usec 0) nil
 215         (setq usec (+ usec profile-million))
 216         (setq sec (1- sec)))
 217       (setcar time (+ sec (car time)))
 218       (setcdr time (+ usec (cdr time)))
 219       (if (< (cdr time) profile-million) nil
 220         (setcar time (1+ (car time)))
 221         (setcdr time (- (cdr time) profile-million)))
 222       )))
 223
 224 (defun profile-convert-byte-code (function)
 225   (let ((defn (symbol-function function)))
 226     (if (byte-code-function-p defn)
 227         ;; It is a compiled code object.
 228         (let* ((contents (append defn nil))
 229                (body
 230                 (list (list 'byte-code (nth 1 contents)
 231                             (nth 2 contents) (nth 3 contents)))))
 232           (if (nthcdr 5 contents)
 233               (setq body (cons (list 'interactive (nth 5 contents)) body)))
 234           (if (nth 4 contents)
 235               ;; Use `documentation' here, to get the actual string,
 236               ;; in case the compiled function has a reference
 237               ;; to the .elc file.
 238               (setq body (cons (documentation function) body)))
 239           (fset function (cons 'lambda (cons (car contents) body)))))))
 240
 241 (defun profile-a-function (fun)
 242   "Profile the function FUN."
 243   (interactive "aFunction to profile: ")
 244   (profile-convert-byte-code fun)
 245   (let ((def (symbol-function fun)) (funlen (length (symbol-name fun))))
 246     (if (eq (car def) 'lambda) nil
 247       (error "To profile: %s must be a user-defined function" fun))
 248     (setq profile-time-list             ; add a new entry
 249           (cons (cons fun (cons 0 (cons 0 0))) profile-time-list))
 250     (setq profile-init-list             ; add a new entry
 251           (cons (cons fun (cons 0 (cons 0 0))) profile-init-list))
 252     (if (< profile-max-fun-name funlen) (setq profile-max-fun-name funlen))
 253     (fset fun (profile-fix-fun fun def))))
 254
 255 (defun profile-fix-fun (fun def)
 256   "Take function FUN and return it fixed for profiling.
 257 DEF is (symbol-function FUN)."
 258   (let (prefix first second third (count 2) inter suffix)
 259     (if (< (length def) 3)
 260         nil             ; nothing to see
 261       (setq first (car def) second (car (cdr def))
 262             third (car (nthcdr 2 def)))
 263       (setq prefix (list first second))
 264       ;; Skip the doc string, if there is a string
 265       ;; which serves only as a doc string,
 266       ;; and put it in PREFIX.
 267       (if (or (not (stringp third)) (not (nthcdr 3 def)))
 268           ;; Either no doc string, or it is also the function value.
 269           (setq inter third)
 270         ;; Skip the doc string,
 271         (setq count 3
 272               prefix (nconc prefix (list third))
 273               inter (car (nthcdr 3 def))))
 274       ;; Check for an interactive spec.
 275       ;; If found, put it inu  PREFIX and skip it.
 276       (if (not (and (listp inter)
 277                     (eq (car inter) 'interactive)))
 278           nil
 279         (setq prefix (nconc prefix (list inter)))
 280         (setq count (1+ count)))        ; skip this sexp for suffix
 281       ;; Set SUFFIX to the function body forms.
 282       (setq suffix (nthcdr count def))
 283       (if (equal (car suffix) '(profile-get-time))
 284           nil
 285         ;; Prepare new function definition.
 286         (nconc prefix
 287                (list '(profile-get-time)) ; read time
 288                (list (list 'profile-start-function
 289                            (list 'quote fun)))
 290                (list (list 'setq 'profile-temp-result-
 291                            (nconc (list 'progn) suffix)))
 292                (list '(profile-get-time)) ; read time
 293                (list (list 'profile-update-function
 294                            (list 'quote fun)))
 295                (list 'profile-temp-result-)
 296                )))))
 297
 298 (defun profile-restore-fun (fun)
 299   "Restore profiled function FUN to its original state."
 300   (let ((def (symbol-function (car fun))) body index)
 301     ;; move index beyond header
 302     (setq index (cdr def))
 303     (if (stringp (car (cdr index))) (setq index (cdr index)))
 304     (if (and (listp (car (cdr index)))
 305              (eq (car (car (cdr index))) 'interactive))
 306         (setq index (cdr index)))
 307     (setq body (car (nthcdr 3 index)))
 308     (if (and (listp body)               ; the right element ?
 309              (eq (car (cdr body)) 'profile-temp-result-))
 310         (setcdr index (cdr (car (cdr (cdr body))))))))
 311
 312 (defun profile-finish ()
 313   "Stop profiling functions.  Clear all the settings."
 314   (interactive)
 315   (mapcar 'profile-restore-fun profile-time-list)
 316   (setq profile-max-fun-name 0)
 317   (setq profile-time-list nil)
 318   (setq profile-init-list nil))
 319
 320 (defun profile-quit ()
 321   "Kill the timer process."
 322   (interactive)
 323   (process-send-string profile-timer-process "q\n"))
 324
 325 ;;; profile.el ends here