cgit.sxemacs.org Git - packages/blob - xemacs-packages/xemacs-devel/profile.el

   1 ;;; profile.el --- basic profiling commands for XEmacs
   2
   3 ;; Copyright (C) 1996, 2002, 2003, 2004 Ben Wing.
   4 ;; Copyright (C) 1997 Free Software Foundation.
   5
   6 ;; Author: Ben Wing <ben@xemacs.org>
   7 ;; Maintainer: XEmacs Development Team
   8 ;; Keywords: internal
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF.
  28
  29 ;;; Commentary:
  30
  31 ;; In addition to Lisp-based `elp', XEmacs provides a set of
  32 ;; primitives able to profile evaluation of Lisp functions, created by
  33 ;; the illustrious Ben Wing.  The functions in this file can be used
  34 ;; to gain easy access to the internal profiling functions.
  35
  36 ;; The profiler works by catching "ticks" (actually SIGPROF signals),
  37 ;; and looking at the current Lisp function, at the time of each tick.
  38 ;; In addition, call counts for each function called are recorded.
  39 ;; `profile-results' pretty-prints this information.
  40
  41 ;; Note (ELP users should read this):
  42 ;;
  43 ;; 1) Both function and function + descendants time are reported.
  44 ;; 2) Number of times called is recorded for each function, as well as
  45 ;;    Lisp allocation for the functions and for function + descendants.
  46 ;; 3) The profiling entries include not only functions but also certain
  47 ;;    common internal operations, such as redisplay, garbage collection,
  48 ;;    byte-char conversion, internal-external conversion, etc.  Profiling
  49 ;;    overhead is also recorded.
  50 ;; 4) Each tick is equivalent to 1ms (which can be changed), but this
  51 ;;    is CPU time (user+kernel), not the real time.
  52 ;; 5) Only the actual funcalls are profiled.  If, in the C code, a subr
  53 ;;    Ffoo calls Fbar directly, using Fbar(), only Ffoo will appear in
  54 ;;    the profile.
  55 ;; 6) When profiling complex forms, more meaningful results are achieved
  56 ;;    by byte-compiling, e.g. with `compile-and-profile'.
  57 ;; 7) Results will be skewed if your XEmacs is compiled with error-
  58 ;;    checking.  The best thing is to compile with optimization and without
  59 ;;    error-checking, before profiling.
  60 ;; 8) If you call `profile-key-sequence' and then hit a sequence starting
  61 ;;    with `M-x ...', the profiling will start from when you hit M-x,
  62 ;;    and will include the reading of the rest of the command.
  63
  64 ;; There are three levels of functions:
  65 ;;
  66 ;; -- High-level interactive commands for profiling key sequences, commands,
  67 ;;    and expressions (`profile-key-sequence', `profile-command',
  68 ;;    `profile-expression'), or for interactively profiling any sequence of
  69 ;;    commands (`toggle-profiling').
  70 ;;
  71 ;; -- Functions for profiling forms, optionally byte-compiled (`profile',
  72 ;;    `continue-profile', `compile-and-profile',
  73 ;;    `compile-and-continue-profile'), which can be conveniently executed
  74 ;;    from the `Eval:' prompt or *scratch* buffer.  Use the `compile-and-'
  75 ;;    versions with complex forms, for more meaningful results.
  76 ;;
  77 ;; -- The basic API, for complete control over the profiling process
  78 ;;    (`clear-profiling-info', `start-profiling', `stop-profiling',
  79 ;;     `profile-results', `get-profiling-info', `combine-profiling-info',
  80 ;;     `save-profiling-info').
  81 ;;
  82 ;; For instance, to see where Gnus spends time when generating
  83 ;; Summary buffer, go to the group buffer and press
  84 ;; `M-x profile-key-sequence RET SPC'; or just do
  85 ;; `M-x toggle-profiling', hit SPC, and do `M-x toggle-profiling' again.
  86 ;; (This is especially convenient if you bind `toggle-profiling' to a
  87 ;; keystroke.)
  88
  89 \f
  90 ;;; Code:
  91
  92 ;;; FIXME: This is (almost) a direct copy of `with-displaying-help-buffer'
  93 ;; that exists only in 21.5 core.  When 21.5 is stable I'd suggest
  94 ;; that this macro be removed and the call to it in `profile-results'
  95 ;; (see fixme comment in that function) below be changed to use the
  96 ;; macro in core.  This is here because the packages are built with
  97 ;; 21.4 so when this file is byte-compiled it doesn't include the
  98 ;; definition of the `with-displaying-temp-buffer'.  Which was OK for
  99 ;; 21.4 users, but 21.5 users would lose. --SY.
 100 (defmacro profile-displaying-temp-buffer (name &rest body)
 101   "Form which makes a help buffer with given NAME and evaluates BODY there.
 102
 103 Use this function for displaying information in temporary buffers, where the
 104 user will typically view the information and then exit using
 105 \\<temp-buffer-mode-map>\\[help-mode-quit].
 106
 107 The buffer is put into the mode specified in `mode-for-temp-buffer'."
 108   `(let* ((winconfig (current-window-configuration))
 109           (was-one-window (one-window-p))
 110           (buffer-name ,name)
 111           (help-not-visible
 112            (not (and (windows-of-buffer buffer-name) ;shortcut
 113                      (memq (selected-frame)
 114                            (mapcar 'window-frame
 115                                    (windows-of-buffer buffer-name)))))))
 116     (help-register-and-maybe-prune-excess buffer-name)
 117     ;; if help-sticky-window is bogus or deleted, get rid of it.
 118     (if (and help-sticky-window (or (not (windowp help-sticky-window))
 119                                     (not (window-live-p help-sticky-window))))
 120         (setq help-sticky-window nil))
 121     (prog1
 122         (let ((temp-buffer-show-function
 123                (if help-sticky-window
 124                    #'(lambda (buffer)
 125                        (set-window-buffer help-sticky-window buffer))
 126                  temp-buffer-show-function)))
 127           (with-output-to-temp-buffer buffer-name
 128             (prog1 (progn ,@body)
 129               (save-excursion
 130                 (set-buffer standard-output)
 131                 (funcall mode-for-help)))))
 132       (let ((helpwin (get-buffer-window buffer-name)))
 133         (when helpwin
 134           ;; If the temp buffer is already displayed on this
 135           ;; frame, don't override the previous configuration
 136           (when help-not-visible
 137             (with-current-buffer (window-buffer helpwin)
 138               (setq help-window-config winconfig)))
 139           (when help-selects-help-window
 140             (select-window helpwin))
 141           (cond ((eq helpwin (selected-window))
 142                  (display-message 'command
 143                    (substitute-command-keys "Type \\[help-mode-quit] to remove window, \\[scroll-up] to scroll the text.")))
 144                 (was-one-window
 145                  (display-message 'command
 146                    (substitute-command-keys "Type \\[delete-other-windows] to remove window, \\[scroll-other-window] to scroll the text.")))
 147                 (t
 148                  (display-message 'command
 149                    (substitute-command-keys "Type \\[switch-to-buffer-other-window] to restore the other window, \\[scroll-other-window] to scroll the text.")))))))))
 150
 151 (put 'profile-displaying-temp-buffer 'lisp-indent-function 1)
 152
 153 ;;;###autoload
 154 (defun profile-results (&optional info stream sort-by)
 155   "Print profiling info INFO to STREAM in a pretty format.
 156 If INFO is omitted, the current profiling info is retrieved using
 157  `get-profiling-info'.
 158 If STREAM is omitted, the results will be displayed in a temp buffer
 159  using `with-output-to-temp-buffer'; otherwise, they will simply be
 160  printed into STREAM.  Use `standard-output' explicitly if you
 161  want standard output.
 162 If SORT-BY is `call-count' (interactively, the prefix arg), display items
 163  sorted by call count rather than timing.  If `gc-usage' (interactively,
 164  use C-u C-u), sort by GC usage."
 165   (interactive (list nil nil (cond ((equal current-prefix-arg '(16))
 166                                     'gc-usage)
 167                                    (current-prefix-arg 'call-count))))
 168   (or info (setq info (get-profiling-info)))
 169   (if (not stream)
 170       ;; FIXME: change this to `with-displaying-temp-buffer' when that
 171       ;; exists in stable XEmacs. --SY.
 172       (profile-displaying-temp-buffer "*Profiling Results*"
 173         (profile-results info standard-output sort-by))
 174     (let* ((standard-output stream)
 175            ;; #### Support old profile format for the moment
 176            (timing (if (consp (car info)) (copy-alist info)
 177                      (loop for x being the hash-key in (getf info 'timing)
 178                        using (hash-value y)
 179                        collect (cons x y))))
 180            (total-timing (if (boundp 'call-count-profile-table)
 181                                (make-hash-table)
 182                              (getf info 'total-timing)))
 183            (call-count (if (boundp 'call-count-profile-table)
 184                            call-count-profile-table
 185                          (getf info 'call-count)))
 186            (gc-usage (if (boundp 'call-count-profile-table)
 187                          (make-hash-table)
 188                        (getf info 'gc-usage)))
 189            (total-gc-usage (if (boundp 'call-count-profile-table)
 190                                (make-hash-table)
 191                              (getf info 'total-gc-usage)))
 192            (spaces-for-data 41)
 193            (spaces-for-fun (- 79 spaces-for-data))
 194            maxfunlen)
 195       (loop for table in (list total-timing call-count gc-usage total-gc-usage)
 196         do
 197         ;; Add entries for any functions in other tables but no ticks
 198         (loop for x being the hash-key in table using (hash-value y) do
 199           (if (not (assoc x timing))
 200               (push (cons x 0) timing))))
 201       ;; Calculate the longest function
 202       (setq maxfunlen
 203             (apply #'max
 204                    (length "Function Name")
 205                    (mapcar
 206                     (lambda (el)
 207                       (let ((l (length (format "%s" (car el)))))
 208                         (if (<= l spaces-for-fun)
 209                             l 0)))
 210                     timing)))
 211       (princ (format "%-*sTicks/Total %%Usage Calls GC-Usage/  Total\n"
 212                      maxfunlen "Function Name"))
 213       (princ (make-string maxfunlen ?=))
 214       (princ "=====/===== ====== ===== ========/=======\n")
 215       (let ((timing-sum (float (apply #'+ (mapcar #'cdr timing))))
 216             (calls-sum 0)
 217             (gc-sum 0))
 218         (dolist (entry
 219                  (nreverse
 220                   (sort timing
 221                         (cond ((eq sort-by 'call-count)
 222                                #'(lambda (a b)
 223                                    (< (or (gethash (car a) call-count) 0)
 224                                       (or (gethash (car b) call-count) 0))))
 225                               ((eq sort-by 'gc-usage)
 226                                #'(lambda (a b)
 227                                    (< (or (gethash (car a) gc-usage) 0)
 228                                       (or (gethash (car b) gc-usage) 0))))
 229                               (t #'cdr-less-than-cdr)))))
 230           (princ (format "%-*s%5d/%5d %6.3f %s %s\n"
 231                          maxfunlen
 232                          ;; if function too long (often lambdas or compiled
 233                          ;; funs), put in a newline to keep the alignment
 234                          (let ((str (format "%s" (car entry))))
 235                            (if (<= (length str) maxfunlen) str
 236                              (concat str "\n" (make-string maxfunlen ? ))))
 237                          (cdr entry)
 238                          (or (gethash (car entry) total-timing) 0)
 239                          (if (zerop timing-sum)
 240                              0
 241                            (* 100 (/ (cdr entry) timing-sum)))
 242                          (let ((count (gethash (car entry) call-count)))
 243                            (if count (format "%5d" count) "     "))
 244                          (let ((gcval (or (gethash (car entry) gc-usage) 0))
 245                                (total-gcval
 246                                 (or (gethash (car entry) total-gc-usage) 0)))
 247                            (if (or (/= gcval 0) (/= total-gcval 0))
 248                                (format "%8d/%7d" gcval total-gcval)
 249                              "                "))
 250                          ))
 251           (incf calls-sum (or (gethash (car entry) call-count 0)))
 252           (incf gc-sum (or (gethash (car entry) gc-usage 0)))
 253           )
 254         (princ (make-string (+ maxfunlen spaces-for-data) ?-))
 255         (princ (format "\n%-*s%7d      %7.3f %5d %8d\n"
 256                        (- maxfunlen 2) "Total" timing-sum 100.0 calls-sum
 257                        gc-sum))
 258         (princ (format "\n
 259 Ticks/Total     = Ticks this function/this function and descendants
 260 Calls           = Number of calls to this function
 261 GC-Usage/Total  = Lisp allocation this function/this function and descendants
 262 One tick        = %g ms\n"
 263                        (/ default-profiling-interval 1000.0)))
 264         (and (boundp 'internal-error-checking)
 265              (remq 'quick-build internal-error-checking)
 266              (princ "
 267 WARNING: Error checking is turned on in this XEmacs.  This might make
 268          the measurements very unreliable.\n"))))))
 269
 270 ;;;###autoload
 271 (defun combine-profiling-info (&rest info)
 272   "Add up the profiling results accumulated during many profiling sessions.
 273 See `profile'."
 274   (if (boundp 'call-count-profile-table)
 275       ;; #### old format
 276       (let ((hash (make-hash-table :test 'equal)))
 277         (loop for i in info do
 278           (loop for (x . y) in i do
 279             (puthash x (+ y (or (gethash x hash) 0)) hash)))
 280         (loop for x being the hash-key in hash using (hash-value y)
 281           collect (cons x y)))
 282     (let ((ninfo (list 'timing (make-hash-table :test 'equal)
 283                        'total-timing (make-hash-table :test 'equal)
 284                        'call-count (make-hash-table :test 'equal)
 285                        'gc-usage (make-hash-table :test 'equal)
 286                        'total-gc-usage (make-hash-table :test 'equal)
 287                        )))
 288       (loop
 289         for i in info do
 290         (loop for (key hash) on i by #'cddr
 291           for reshash = (getf ninfo key) do
 292           (loop for x being the hash-key in hash using (hash-value y) do
 293             (puthash x (+ (or y 0) (or (gethash x reshash) 0)) reshash))))
 294       ninfo)))
 295
 296 ;;;###autoload
 297 (defmacro save-profiling-info (&rest body)
 298   "Execute BODY, preserving the profiling info and profiling on-ness."
 299   (let ((old-profiling-info (gensym "spi"))
 300         (old-was-profiling (gensym "spi")))
 301   `(let ((,old-profiling-info (get-profiling-info))
 302          (,old-was-profiling (profiling-active-p)))
 303      (unwind-protect
 304          (progn ,@body)
 305        (if (not (eq ,old-was-profiling (profiling-active-p)))
 306            (if ,old-was-profiling (start-profiling) (stop-profiling)))
 307        (set-profiling-info ,old-profiling-info)))))
 308
 309 ;;;###autoload
 310 (defmacro profile (&rest forms)
 311   "Profile FORMS and display results in a temporary buffer.
 312 This clears out existing profiling info, turns on profiling, executes
 313 the forms, turns off profiling, and displays the results.
 314
 315 If you want to accumulate the results of multiple profiling runs, you can
 316 use `continue-profile', which does not clear out existing profiling info.
 317
 318 If you are looking for high-level interactive commands for profiling key
 319 sequences, commands, and expressions, see `profile-key-sequence',
 320 `profile-command', and `profile-expression'.
 321
 322 See also `toggle-profiling', which lets you easily profile any sequence
 323 of commands.
 324
 325 If you need more control over what is profiled and what isn't, use the more
 326 basic functions `clear-profiling-info', `start-profiling',
 327 `stop-profiling', `profile-results', `get-profiling-info',
 328 `combine-profiling-info' and `save-profiling-info'."
 329   `(progn
 330     (clear-profiling-info)
 331      (unwind-protect
 332          (progn
 333            (start-profiling)
 334            ,@forms)
 335        (stop-profiling))
 336     (profile-results)))
 337
 338 ;;;###autoload
 339 (defmacro continue-profile (&rest forms)
 340   "Profile FORMS, combining the results with previous profile runs.
 341 Display results in a temporary buffer.  Unlike `profile', this does
 342 not clear out existing profile information first, and will leave profiling
 343 on if it was already on when this macro was invoked."
 344   `(let ((was-profiling (profiling-active-p)))
 345      (unwind-protect
 346          (progn
 347            (start-profiling)
 348            ,@forms)
 349        (unless was-profiling
 350          (stop-profiling)))
 351      (profile-results)))
 352
 353 (put 'profile 'lisp-indent-function 0)
 354 (put 'continue-profile 'lisp-indent-function 0)
 355
 356 ;;;###autoload
 357 (defun profile-expression (expr &optional arg)
 358   "Eval EXPR, profiling the execution and displaying the results.
 359 With prefix, combine results with results from a previous run."
 360   (interactive (list (read (read-string "Expression to profile: "))
 361                      current-prefix-arg))
 362   (if arg (continue-profile (eval expr))
 363     (profile (eval expr))))
 364
 365 ;;;###autoload
 366 (defun profile-command (command &optional arg)
 367   "Run COMMAND, profiling the execution and displaying the results.
 368 With prefix, combine results with results from a previous run."
 369   (interactive "CCommand to profile: \nP")
 370   (if arg (continue-profile (call-interactively command))
 371     (profile (call-interactively command))))
 372
 373 ;;;###autoload
 374 (defun profile-key-sequence (keys &optional arg)
 375   "Dispatch the key sequence KEYS, profile the execution and show the results.
 376 KEYS can be a vector of keypress events, a keypress event, or a character.
 377 With prefix, combine results with results from a previous run."
 378   (interactive "kProfile keystroke: \nP")
 379   (and (characterp keys)
 380        (setq keys (character-to-event keys)))
 381   (or (vectorp keys)
 382       (setq keys (vector keys)))
 383   (if arg (continue-profile (mapc 'dispatch-event keys))
 384     (profile (mapc 'dispatch-event keys))))
 385
 386 ;;;###autoload
 387 (defun toggle-profiling ()
 388   "Start profiling, or stop it and print results.
 389 This lets you figure out where time is being spent when executing Lisp code."
 390   (interactive)
 391   (if (profiling-active-p)
 392       (progn
 393         (stop-profiling)
 394         (message "...Finished profiling")
 395         (profile-results))
 396     (message "Profiling...")
 397     (clear-profiling-info)
 398     (start-profiling)))
 399
 400 ;;;###autoload
 401 (defmacro compile-and-profile (&rest forms)
 402   "Byte compile FORMS, profile the execution, and pretty-print the results."
 403   `(progn
 404      (flet ((compiled-code-being-profiled () ,@forms))
 405        (byte-compile 'compiled-code-being-profiled)
 406        (profile (compiled-code-being-profiled)))))
 407
 408 ;;;###autoload
 409 (defmacro compile-and-continue-profile (&rest forms)
 410   "Like `compile-and-profile' but combine results with previous profile runs."
 411   `(progn
 412      (flet ((compiled-code-being-profiled () ,@forms))
 413        (byte-compile 'compiled-code-being-profiled)
 414        (continue-profile (compiled-code-being-profiled)))))
 415
 416 ;;; profile.el ends here