1. xemacs
  2. xemacs-devel


xemacs-devel / profile.el

;;; profile.el --- basic profiling commands for XEmacs

;; Copyright (C) 1996, 2002 Ben Wing.
;; Copyright (C) 1997 Free Software Foundation.

;; Maintainer: XEmacs Development Team
;; Keywords: internal

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the 
;; Free Software Foundation, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: Not in FSF.

;;; Commentary:

;; In addition to Lisp-based `elp', XEmacs provides a set of
;; primitives able to profile evaluation of Lisp functions, created by
;; the illustrious Ben Wing.  The functions in this file can be used
;; to gain easy access to the internal profiling functions.

;; The profiler works by catching "ticks" (actually SIGPROF signals),
;; and looking at the current Lisp function, at the time of each tick.
;; In addition, call counts for each function called are recorded.
;; `profile-results' pretty-prints this information.

;; Caveats (ELP users should read this):
;; 1) The time reported is function time, rather than
;;    function+descendants time;
;; 2) Each tick is equivalent to 1ms (which can be changed), but this
;;    is CPU time (user+kernel), not the real time;
;; 3) Only the actual funcalls are profiled.  If, in the C code, a subr
;;    Ffoo calls Fbar directly, using Fbar (), only Ffoo will appear in
;;    the profile.
;; 4) When profiling complex forms, more meaningful results are achieved
;;    by byte-compiling, e.g. with `compile-and-profile'.

;; There are three levels of functions:
;; -- High-level interactive commands for profiling key sequences, commands,
;;    and expressions (`profile-key-sequence', `profile-command',
;;    `profile-expression').
;; -- Functions for profiling forms, optionally byte-compiled (`profile',
;;    `continue-profile', `compile-and-profile',
;;    `compile-and-continue-profile'), which can be conveniently executed
;;    from the `Eval:' prompt or *scratch* buffer.  Use the `compile-and-'
;;    versions with complex forms, for more meaningful results.
;; -- The basic API, for complete control over the profiling process
;;    (`clear-profiling-info', `start-profiling', `stop-profiling',
;;     `profile-results', `get-profiling-info', `combine-profiling-info',
;;     `save-profiling-info').
;; For instance, to see where Gnus spends time when generating
;; Summary buffer, go to the group buffer and press
;; `M-x profile-key-sequence RET SPC'.

;;; Code:

(defun profile-results (&optional info stream sort-by-call-count)
  "Print profiling info INFO to STREAM in a pretty format.
If INFO is omitted, the current profiling info is retrieved using
If STREAM is omitted, the results will be displayed in a temp buffer
 using `with-output-to-temp-buffer'; otherwise, they will simply be
 printed into STREAM.  Use `standard-output' explicitly if you
 want standard output.
If SORT-BY-CALL-COUNT is non-nil (interactively, the prefix arg),
 display items sorted by call count rather than timing."
  (interactive (list nil nil current-prefix-arg))
  (if sort-by-call-count (beep))
  (or info (setq info (get-profiling-info)))
  (if (not stream)
      (if (fboundp 'with-displaying-temp-buffer)
	  (with-displaying-temp-buffer "*Profiling Results*"
	      (profile-results info standard-output sort-by-call-count))
	(pop-to-buffer (get-buffer-create "*Profiling Results*"))
	(profile-results info (current-buffer))
	(goto-char (point-min)))
    (let* ((standard-output stream)
	   ;; #### Support old profile format for the moment
	   (timing (if (consp (car info)) (copy-alist info)
		     (loop for x being the hash-key in (getf info 'timing)
		       using (hash-value y)
		       collect (cons x y))))
	   (call-count (if (boundp 'call-count-profile-table)
			 (getf info 'call-count)))
      ;; Add entries for any functions with call counts but no ticks
      (loop for x being the hash-key in call-count using (hash-value y) do
	(if (not (assoc x timing))
	    (push (cons x 0) timing)))
      ;; Calculate the longest function
      (setq maxfunlen
	    (apply #'max
		   (length "Function Name")
		    (lambda (el)
		      ;; Functions longer than 50 characters (usually
		      ;; anonymous functions) don't qualify
		      (let ((l (length (format "%s" (car el)))))
			(if (< l 50)
			    l 0)))
      (princ (format "%-*s    Ticks    %%/Total   Call Count\n"
		     maxfunlen "Function Name"))
      (princ (make-string maxfunlen ?=))
      (princ "    =====    =======   ==========\n")
      (let ((sum (float (apply #'+ (mapcar #'cdr timing)))))
	(dolist (entry
		  (sort timing
			(if sort-by-call-count
			    #'(lambda (a b)
				(< (or (gethash (car a) call-count) 0)
				   (or (gethash (car b) call-count) 0)))
	  (princ (format "%-*s %8d    %7.3f    %s\n"
			 maxfunlen (car entry) (cdr entry)
			 (* 100 (/ (cdr entry) sum))
			 (let ((count (gethash (car entry) call-count)))
			   (if count (format "%9d" count) "")))))
	(princ (make-string maxfunlen ?-))
	(princ "---------------------------------\n")
	(princ (format "%-*s    %5d    %7.3f\n" maxfunlen "Total" sum 100.0))
	(princ (format "\n\nOne tick = %g ms\n"
		       (/ default-profiling-interval 1000.0)))
	(and (boundp 'internal-error-checking)
	     (delq 'quick-build internal-error-checking)
	     (princ "
WARNING: Error checking is turned on in this XEmacs.  This might make
         the measurements very unreliable.\n"))))))

(defun combine-profiling-info (&rest info)
  "Add up the profiling results accumulated during many profiling sessions.
See `profile'."
  (if (boundp 'call-count-profile-table)
      ;; #### old format
      (let ((hash (make-hash-table :test 'equal)))
	(loop for i in info do
	  (loop for (x . y) in i do
	    (puthash x (+ y (or (gethash x hash) 0)) hash)))
	(loop for x being the hash-key in hash using (hash-value y)
	  collect (cons x y)))
    (let ((ninfo (list 'timing (make-hash-table :test 'equal)
		       'call-count (make-hash-table :test 'equal))))
	for i in info do
	(loop for (key hash) on i by #'cddr
	  for reshash = (getf ninfo key) do
	  (loop for x being the hash-key in hash using (hash-value y) do
	    (puthash x (+ (or y 0) (or (gethash x reshash) 0)) reshash))))

(defmacro save-profiling-info (&rest body)
  "Execute BODY, preserving the profiling info and profiling on-ness."
  (let ((old-profiling-info (gensym "spi"))
	(old-was-profiling (gensym "spi")))
  `(let ((,old-profiling-info (get-profiling-info))
	 (,old-was-profiling (profiling-active-p)))
	 (progn ,@body)
       (if (not (eq ,old-was-profiling (profiling-active-p)))
	   (if ,old-was-profiling (start-profiling) (stop-profiling)))
       (set-profiling-info ,old-profiling-info)))))

(defmacro profile (&rest forms)
  "Profile FORMS and display results in a temporary buffer.
This clears out existing profiling info, turns on profiling, executes
the forms, turns off profiling, and displays the results.

If you want to accumulate the results of multiple profiling runs, you can
use `continue-profile', which does not clear out existing profiling info.

If you are looking for high-level interactive commands for profiling key
sequences, commands, and expressions, see `profile-key-sequence',
`profile-command', and `profile-expression'.

If you need more control over what is profiled and what isn't, use the more
basic functions `clear-profiling-info', `start-profiling',
`stop-profiling', `profile-results', `get-profiling-info',
`combine-profiling-info' and `save-profiling-info'."

(defmacro continue-profile (&rest forms)
  "Profile FORMS, combining the results with previous profile runs.
Display results in a temporary buffer.  Unlike `profile', this does
not clear out existing profile information first, and will leave profiling
on if it was already on when this macro was invoked."
  `(let ((was-profiling (profiling-active-p)))
       (unless was-profiling

(put 'profile 'lisp-indent-function 0)
(put 'continue-profile 'lisp-indent-function 0)

(defun profile-expression (expr &optional arg)
  "Eval EXPR, profiling the execution and displaying the results.
With prefix, combine results with results from a previous run."
  (interactive (list (read (read-string "Expression to profile: "))
  (if arg (continue-profile (eval expr))
    (profile (eval expr))))

(defun profile-command (command &optional arg)
  "Run COMMAND, profiling the execution and displaying the results.
With prefix, combine results with results from a previous run."
  (interactive "CCommand to profile: \nP")
  (if arg (continue-profile (call-interactively command))
    (profile (call-interactively command))))

(defun profile-key-sequence (keys &optional arg)
  "Dispatch the key sequence KEYS, profile the execution and show the results.
KEYS can be a vector of keypress events, a keypress event, or a character.
With prefix, combine results with results from a previous run."
  (interactive "kProfile keystroke: \nP")
  (and (characterp keys)
       (setq keys (character-to-event keys)))
  (or (vectorp keys)
      (setq keys (vector keys)))
  (if arg (continue-profile (mapc 'dispatch-event keys))
    (profile (mapc 'dispatch-event keys))))

(defmacro compile-and-profile (&rest forms)
  "Byte compile FORMS, profile the execution, and pretty-print the results."
     (flet ((compiled-code-being-profiled () ,@forms))
       (byte-compile 'compiled-code-being-profiled)
       (profile (compiled-code-being-profiled)))))

(defmacro compile-and-continue-profile (&rest forms)
  "Like `compile-and-profile' but combine results with previous profile runs."
     (flet ((compiled-code-being-profiled () ,@forms))
       (byte-compile 'compiled-code-being-profiled)
       (continue-profile (compiled-code-being-profiled)))))

;;; profile.el ends here