lisp/emacs-lisp/profile.el

   1 ;;; profile.el -- generate run time measurements of Emacs Lisp functions
   2
   3 ;; Author: Boaz Ben-Zvi <boaz@lcs.mit.edu>
   4 ;; Created: 07 Feb 1992
   5 ;; Last-Modified: 07 Feb 1992
   6 ;; Version: 1.0
   7 ;; Adapted-By: ESR
   8 ;; Keywords: lisp, tools
   9
  10 ;; Copyright (C) 1992 Free Software Foundation, Inc.
  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 2, 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
  26 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, 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 included with this package 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 ; HOW TO INSTALL:
  70 ; ---------------
  71 ;   First you need to compile and install the following C program in your
  72 ; path under the name "emacs-timer" (or set the variable
  73 ; profile-timer-program  to whatever name you picked).
  74 ;
  75 ;/**
  76 ; **  To be run as an emacs process. Input string that starts with:
  77 ; **    'z' -- resets the watch (to zero).
  78 ; **    'p' -- return time (on stdout) as string with format <sec>.<micro-sec>
  79 ; **    'q' -- exit.
  80 ; **
  81 ; **  abstraction : a stopwatch
  82 ; **  operations: reset_watch, get_time
  83 ; */
  84 ;#include <strings.h>
  85 ;#include <sys/time.h>
  86 ;#include <stdio.h>
  87 ;static struct timeval TV1,TV2;
  88 ;static struct timezone *tzp = (struct timezone *) NULL; /* no need timezone */
  89 ;static int watch_not_started = 1 ; /* flag */
  90 ;static char time_string[30]
  91 ;
  92 ;int reset_watch()    /* this call resets the stopwatch to zero */
  93 ;{
  94 ;    gettimeofday(&TV1, tzp) ;
  95 ;    watch_not_started = 0;
  96 ;}
  97 ;
  98 ;char *get_time()
  99 ;   /* this call returns the time since the last reset_watch() call. The time
 100 ;       is returned as a string with the format  <seconds>.<micro-seconds>
 101 ;       If reset_watch() was not called yet, returns NULL */
 102 ;{
 103 ;    char *result = time_string ;
 104 ;    int i;
 105 ;    if (watch_not_started) return((char *) 0);  /* call reset_watch first ! */
 106 ;    gettimeofday(&TV2, tzp);
 107 ;    if ( TV1.tv_usec > TV2.tv_usec )
 108 ;    {
 109 ;       TV2.tv_usec += 1000000;
 110 ;       TV2.tv_sec--;
 111 ;    }
 112 ;    sprintf(result,"%lu.%6lu",
 113 ;           TV2.tv_sec - TV1.tv_sec, TV2.tv_usec - TV1.tv_usec);
 114 ;    for (result = index(result,'.') + 1 ; *result == ' ' ; result++ )
 115 ;       *result = '0';
 116 ;    return(time_string);
 117 ;}
 118 ;
 119 ;void main()
 120 ;{
 121 ;    char inp[10];
 122 ;    while (1)
 123 ;    {
 124 ;       gets(inp);
 125 ;       switch (inp[0])
 126 ;       {
 127 ;       case 'z': reset_watch();
 128 ;           break;
 129 ;       case 'p': puts(get_time());
 130 ;           break;
 131 ;       case 'q': exit(0);
 132 ;       }
 133 ;   }
 134 ;}
 135 ; -------- end of clip ----------------
 136
 137 ;;; Code:
 138
 139 ;;;
 140 ;;;  User modifiable VARIABLES
 141 ;;;
 142
 143 (defvar profile-functions-list nil "*List of functions to profile")
 144 (defvar profile-timer-program "emacs-timer" "*Name of the timer program")
 145
 146 ;;;
 147 ;;; V A R I A B L E S
 148 ;;;
 149
 150 (defvar profile-timer-process nil "Process running the timer")
 151 (defvar profile-time-list nil
 152     "List of accumulative time for each profiled function")
 153 (defvar profile-init-list nil
 154     "List of entry time for each function. \n\
 155 Both how many times invoked and real time of start.")
 156 (defvar profile-max-fun-name 0 "Max length of name of any function profiled")
 157 (defvar profile-temp-result- nil "Should NOT be used anywhere else")
 158 (defvar profile-time (cons 0 0) "Used to return result from a filter")
 159 (defvar profile-buffer "*profile*" "Name of profile buffer")
 160
 161 ;;;
 162 ;;; F U N C T I O N S
 163 ;;;
 164
 165 (defun profile-functions (&optional flist)
 166     "Profile all the functions listed in profile-functions-list.\n\
 167 With argument FLIST, use the list FLIST instead."
 168     (interactive "*P")
 169     (if (null flist) (setq flist profile-functions-list))
 170     (mapcar 'profile-a-function flist))
 171
 172 (defun profile-filter (process input)
 173     "Filter for the timer process. Sets profile-time to the returned time."
 174     (if (zerop (string-match "\\." input))
 175             (error "Bad output from %s" profile-timer-program)
 176         (setcar profile-time
 177                 (string-to-int (substring input 0 (match-beginning 0))))
 178         (setcdr profile-time
 179                 (string-to-int (substring input (match-end 0))))))
 180
 181
 182 (defun profile-print (entry)
 183     "Print one ENTRY (from profile-time-list) ."
 184     (let ((time (cdr entry)) str (offset 5))
 185         (insert (format "%s" (car entry)) space)
 186         (move-to-column ref-column)
 187         (setq str (int-to-string (car time)))
 188         (insert str)
 189         (if (>= (length str) offset) nil
 190             (move-to-column ref-column)
 191             (insert (substring spaces 0 (- offset (length str))))
 192             (forward-char (length str)))
 193         (setq str (int-to-string (cdr time)))
 194         (insert "." (substring "000000" 0 (- 6 (length str))) str "\n")
 195         ))
 196
 197 (defconst spaces "                                                         ")
 198
 199 (defun profile-results ()
 200     "Display profiling results in  profile-buffer ."
 201     (interactive)
 202     (let* ((ref-column (+ 8 profile-max-fun-name))
 203            (space (substring spaces 0 ref-column)))
 204         (switch-to-buffer profile-buffer)
 205         (erase-buffer)
 206         (insert "Function" space)
 207         (move-to-column ref-column)
 208         (insert "Time (Seconds.Useconds)\n" "========" space )
 209         (move-to-column ref-column)
 210         (insert "=======================\n")
 211         (mapcar 'profile-print profile-time-list)))
 212
 213 (defun profile-reset-timer ()
 214     (process-send-string profile-timer-process "z\n"))
 215
 216 (defun profile-check-zero-init-times (entry)
 217     "If ENTRY has non zero time, give an error."
 218     (let ((time (cdr (cdr entry))))
 219         (if (and (zerop (car time)) (zerop (cdr time))) nil ; OK
 220             (error "Process timer died while making performance profile."))))
 221
 222 (defun profile-get-time ()
 223     "Get time from timer process into profile-time ."
 224     ;; first time or if process dies
 225     (if (and (processp profile-timer-process)
 226              (eq 'run (process-status profile-timer-process))) nil
 227         (setq profile-timer-process   ;; [re]start the timer process
 228               (start-process "timer"
 229                              (get-buffer-create profile-buffer)
 230                              profile-timer-program))
 231         (set-process-filter profile-timer-process 'profile-filter)
 232         (process-kill-without-query profile-timer-process)
 233         (profile-reset-timer)
 234         ;; check if timer died during time measurement
 235         (mapcar 'profile-check-zero-init-times profile-init-list))
 236     ;; make timer process return current time
 237     (process-send-string profile-timer-process "p\n")
 238     (accept-process-output))
 239
 240 (defun profile-find-function (fun flist)
 241     "Linear search for FUN in FLIST ."
 242     (if (null flist) nil
 243         (if (eq fun (car (car flist))) (cdr (car flist))
 244             (profile-find-function fun (cdr flist)))))
 245
 246 (defun profile-start-function (fun)
 247     "On entry, keep current time for function FUN."
 248     ;; assumes that profile-time contains the current time
 249     (let ((init-time (profile-find-function fun profile-init-list)))
 250         (if (null init-time) (error "Function %s missing from list" fun))
 251         (if (not (zerop (car init-time))) ;; is it a recursive call ?
 252                 (setcar init-time (1+ (car init-time)))
 253             (setcar init-time 1) ; mark first entry
 254             (setq init-time (cdr init-time))
 255             (setcar init-time (car profile-time))
 256             (setcdr init-time (cdr profile-time)))
 257         ))
 258
 259 (defconst profile-million 1000000)
 260
 261 (defun profile-update-function (fun)
 262     "When the call to the function FUN is finished, add its run time."
 263     ;; assumes that profile-time contains the current time
 264     (let ((init-time (profile-find-function fun profile-init-list))
 265           (accum (profile-find-function fun profile-time-list))
 266           sec usec)
 267         (if (or (null init-time)
 268                 (null accum)) (error "Function %s missing from list" fun))
 269         (setcar init-time (1- (car init-time))) ; pop one level in recursion
 270         (if (not (zerop (car init-time)))
 271                 nil ; in some recursion level, do not update accum. time
 272             (setq init-time (cdr init-time))
 273             (setq sec (- (car profile-time) (car init-time))
 274                   usec (- (cdr profile-time) (cdr init-time)))
 275             (setcar init-time 0) ;  reset time to check for error
 276             (setcdr init-time 0) ;  in case timer process dies
 277             (if (>= usec 0) nil
 278                 (setq usec (+ usec profile-million))
 279                 (setq sec (1- sec)))
 280             (setcar accum (+ sec (car accum)))
 281             (setcdr accum (+ usec (cdr accum)))
 282             (if (< (cdr accum) profile-million) nil
 283                 (setcar accum (1+ (car accum)))
 284                 (setcdr accum (- (cdr accum) profile-million)))
 285             )))
 286
 287 (defun profile-a-function (fun)
 288     "Profile the function FUN"
 289     (interactive "aFunction to profile: ")
 290     (let ((def (symbol-function fun)) (funlen (length (symbol-name fun))))
 291         (if (eq (car def) 'lambda) nil
 292             (error "To profile: %s must be a user-defined function" fun))
 293         (setq profile-time-list                       ; add a new entry
 294               (cons (cons fun (cons 0 0)) profile-time-list))
 295         (setq profile-init-list                  ; add a new entry
 296               (cons (cons fun (cons 0 (cons 0 0))) profile-init-list))
 297         (if (< profile-max-fun-name funlen) (setq profile-max-fun-name funlen))
 298         (fset fun (profile-fix-fun fun def))))
 299
 300 (defun profile-fix-fun (fun def)
 301     "Take function FUN and return it fixed for profiling.\n\
 302 DEF is (symbol-function FUN) ."
 303     (let (prefix first second third (count 2) inter suffix)
 304         (if (< (length def) 3) nil ; nothing to see
 305             (setq first (car def) second (car (cdr def))
 306                   third (car (nthcdr 2 def)))
 307             (setq prefix (list first second))
 308             (if (and (stringp third) (< (length def) 3)) nil ; nothing to see
 309                 (if (not (stringp third))  (setq inter third)
 310                     (setq count 3  ; suffix to start after doc string
 311                           prefix (nconc prefix (list third))
 312                           inter (car (nthcdr 3 def))) ; fourth sexp
 313                     )
 314                 (if (not (and (listp inter)
 315                               (eq (car inter) 'interactive))) nil
 316                     (setq prefix (nconc prefix (list inter)))
 317                     (setq count (1+ count))) ; skip this sexp for suffix
 318                 (setq suffix (nthcdr count def))
 319                 (if (equal (car suffix) '(profile-get-time)) nil ;; already set
 320                     ;; prepare new function
 321                     (nconc prefix
 322                            (list '(profile-get-time))  ; read time
 323                            (list (list 'profile-start-function
 324                                        (list 'quote fun)))
 325                            (list (list 'setq 'profile-temp-result-
 326                                        (nconc (list 'progn) suffix)))
 327                            (list '(profile-get-time))  ; read time
 328                            (list (list 'profile-update-function
 329                                        (list 'quote fun)))
 330                            (list 'profile-temp-result-)
 331                            ))))))
 332
 333 (defun profile-restore-fun (fun)
 334     "Restore profiled function FUN to its original state."
 335     (let ((def (symbol-function (car fun))) body index)
 336         ;; move index beyond header
 337         (setq index (cdr def))
 338         (if (stringp (car (cdr index))) (setq index (cdr index)))
 339         (if (and (listp (car (cdr index)))
 340                  (eq (car (car (cdr index))) 'interactive))
 341                 (setq index (cdr index)))
 342         (setq body (car (nthcdr 3 index)))
 343         (if (and (listp body)  ; the right element ?
 344                  (eq (car (cdr body)) 'profile-temp-result-))
 345                 (setcdr index (cdr (car (cdr (cdr body))))))))
 346
 347 (defun profile-finish ()
 348     "Stop profiling functions. Clear all the settings."
 349     (interactive)
 350     (mapcar 'profile-restore-fun profile-time-list)
 351     (setq profile-max-fun-name 0)
 352     (setq profile-time-list nil)
 353     (setq profile-init-list nil))
 354
 355 (defun profile-quit ()
 356     "Kill the timer process."
 357     (interactive)
 358     (process-send-string profile-timer-process "q\n"))
 359
 360 ;; profile.el ends here