1;;; profile.el --- Emacs profiler (OBSOLETE; use elp.el instead)
2
3;; Copyright (C) 1992, 1994, 1998, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Boaz Ben-Zvi <boaz@lcs.mit.edu>
7;; Created: 07 Feb 1992
8;; Version: 1.0
9;; Adapted-By: ESR
10;; Keywords: lisp, tools
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 the
26;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
27;; Boston, MA 02110-1301, USA.
28
29;;; Commentary:
30
31;; DESCRIPTION:
32;; ------------
33;;   This program can be used to monitor running time performance of Emacs Lisp
34;; functions.  It takes a list of functions and report the real time spent
35;; inside these functions.  (Actually, for each function it reports the amount
36;; of time spent while at least one instance of that function is on the call
37;; stack.  So if profiled function FOO calls profiled function BAR, the time
38;; spent inside BAR is credited to both functions.)
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-buffer "*profile*"
77  "Name of profile buffer.")
78(defvar profile-distinct nil
79  "If non-nil, each time slice gets credited to at most one function.
80\(Namely, the most recent one in the call stack.)  If nil, then the
81time reported for a function includes the entire time from beginning
82to end, even if it called some other function that was also profiled.")
83
84;;;
85;;; V A R I A B L E S
86;;;
87
88(defvar profile-time-list nil
89  "List of cumulative calls and time for each profiled function.
90Each element looks like (FUN NCALLS SEC . USEC).")
91(defvar profile-init-list nil
92  "List of entry time for each function.
93Both how many times invoked and real time of start.
94Each element looks like (FUN DEPTH HISEC LOSEC USEC), where DEPTH is
95the current recursion depth, and HISEC, LOSEC, and USEC represent the
96starting time of the call (or of the outermost recursion).")
97(defvar profile-max-fun-name 0
98  "Max length of name of any function profiled.")
99(defvar profile-call-stack nil
100  "A list of the profiled functions currently executing.
101Used only when profile-distinct is non-nil.")
102(defvar profile-last-time nil
103  "The start time of the current time slice.
104Used only when profile-distinct is non-nil.")
105
106(defconst profile-million 1000000)
107
108;;;
109;;; F U N C T I O N S
110;;;
111
112(defun profile-functions (&optional flist)
113  "Profile all the functions listed in `profile-functions-list'.
114With argument FLIST, use the list FLIST instead."
115  (interactive "P")
116  (mapcar 'profile-a-function (or flist profile-functions-list)))
117
118(defun profile-print (entry)
119  "Print one ENTRY (from `profile-time-list')."
120  (let* ((calls (car (cdr entry)))
121	 (timec (cdr (cdr entry)))
122	 (avgtime (and (not (zerop calls))
123		       (/ (+ (car timec)
124			     (/ (cdr timec) (float profile-million)))
125			  calls))))
126    (insert (format (concat "%-"
127			    (int-to-string profile-max-fun-name)
128			    "s %7d %10d.%06d")
129		    (car entry) calls (car timec) (cdr timec))
130	    (if (null avgtime)
131		"\n"
132	      (format " %18.6f\n" avgtime)))))
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-add-time (dest now prev)
147  "Add to DEST the difference between timestamps NOW and PREV.
148DEST is a pair (SEC . USEC) which is modified in place.
149NOW and PREV are triples as returned by `current-time'."
150  (let ((sec (+ (car dest)
151		(* 65536 (- (car now) (car prev)))
152		(- (cadr now) (cadr prev))))
153	(usec (+ (cdr dest)
154		 (- (car (cddr now)) (car (cddr prev))))))
155    (if (< usec 0)
156	(setq sec (1- sec)
157	      usec (+ usec profile-million))
158      (if (>= usec profile-million)
159	  (setq sec (1+ sec)
160		usec (- usec profile-million))))
161    (setcar dest sec)
162    (setcdr dest usec)))
163
164(defun profile-function-prolog (fun)
165  "Mark the beginning of a call to function FUN."
166  (if profile-distinct
167      (let ((profile-time (current-time)))
168	(if profile-call-stack
169	    (profile-add-time (cdr (cdr (assq (car profile-call-stack)
170					      profile-time-list)))
171			      profile-time profile-last-time))
172	(setq profile-call-stack (cons fun profile-call-stack)
173	      profile-last-time profile-time))
174    (let ((profile-time (current-time))
175	  (init-time (cdr (assq fun profile-init-list))))
176      (if (null init-time) (error "Function %s missing from list" fun))
177      (if (not (zerop (car init-time)));; is it a recursive call ?
178	  (setcar init-time (1+ (car init-time)))
179	(setcar init-time 1)		; mark first entry
180	(setcdr init-time profile-time)))))
181
182(defun profile-function-epilog (fun)
183  "Mark the end of a call to function FUN."
184  (if profile-distinct
185      (let ((profile-time (current-time))
186	    (accum (cdr (assq fun profile-time-list))))
187	(setcar accum (1+ (car accum)))
188	(profile-add-time (cdr accum) profile-time profile-last-time)
189	(setq profile-call-stack (cdr profile-call-stack)
190	      profile-last-time profile-time))
191    (let ((profile-time (current-time))
192	  (init-time (cdr (assq fun profile-init-list)))
193	  (accum (cdr (assq fun profile-time-list))))
194      (if (or (null init-time)
195	      (null accum))
196	  (error "Function %s missing from list" fun))
197      (setcar init-time (1- (car init-time))) ; pop one level in recursion
198      ;; Update only if we've finished the outermost recursive call
199      (when (zerop (car init-time))
200	(setcar accum (1+ (car accum)))
201	(profile-add-time (cdr accum) profile-time (cdr init-time))))))
202
203(defun profile-convert-byte-code (function)
204  (let ((defn (symbol-function function)))
205    (if (byte-code-function-p defn)
206	;; It is a compiled code object.
207	(let* ((contents (append defn nil))
208	       (body
209		(list (list 'byte-code (nth 1 contents)
210			    (nth 2 contents) (nth 3 contents)))))
211	  (if (nthcdr 5 contents)
212	      (setq body (cons (list 'interactive (nth 5 contents)) body)))
213	  (if (nth 4 contents)
214	      ;; Use `documentation' here, to get the actual string,
215	      ;; in case the compiled function has a reference
216	      ;; to the .elc file.
217	      (setq body (cons (documentation function) body)))
218	  (fset function (cons 'lambda (cons (car contents) body)))))))
219
220(defun profile-a-function (fun)
221  "Profile the function FUN."
222  (interactive "aFunction to profile: ")
223  (let ((def (symbol-function fun)))
224    (when (eq (car-safe def) 'autoload)
225      (load (car (cdr def)))
226      (setq def (symbol-function fun)))
227    (fetch-bytecode def))
228  (profile-convert-byte-code fun)
229  (let ((def (symbol-function fun)) (funlen (length (symbol-name fun))))
230    (or (eq (car def) 'lambda)
231	(error "To profile: %s must be a user-defined function" fun))
232    (setq profile-time-list		; add a new entry
233	  (cons (cons fun (cons 0 (cons 0 0))) profile-time-list))
234    (setq profile-init-list		; add a new entry
235	  (cons (cons fun (cons 0 nil)) profile-init-list))
236    (if (< profile-max-fun-name funlen) (setq profile-max-fun-name funlen))
237    (fset fun (profile-fix-fun fun def))))
238
239(defun profile-fix-fun (fun def)
240  "Take function FUN and return it fixed for profiling.
241DEF is (symbol-function FUN)."
242  (if (< (length def) 3)
243      def		; nothing to change
244    (let ((prefix (list (car def) (car (cdr def))))
245	  (suffix (cdr (cdr def))))
246      ;; Skip the doc string, if there is a string
247      ;; which serves only as a doc string,
248      ;; and put it in PREFIX.
249      (if (and (stringp (car suffix)) (cdr suffix))
250	  (setq prefix (nconc prefix (list (car suffix)))
251		suffix (cdr suffix)))
252      ;; Check for an interactive spec.
253      ;; If found, put it into PREFIX and skip it.
254      (if (and (listp (car suffix))
255	       (eq (car (car suffix)) 'interactive))
256	  (setq prefix (nconc prefix (list (car suffix)))
257		suffix (cdr suffix)))
258      (if (eq (car-safe (car suffix)) 'profile-function-prolog)
259	  def				; already profiled
260	;; Prepare new function definition.
261	;; If you change this structure, also change profile-restore-fun.
262	(nconc prefix
263	       (list (list 'profile-function-prolog
264			   (list 'quote fun))
265		     (list 'unwind-protect
266			   (cons 'progn suffix)
267			   (list 'profile-function-epilog
268				 (list 'quote fun)))))))))
269
270(defun profile-restore-fun (fun)
271  "Restore profiled function FUN to its original state."
272  (let ((def (symbol-function fun)) body index)
273    ;; move index beyond header
274    (setq index (cdr-safe def))
275    (if (stringp (car (cdr index)))
276	(setq index (cdr index)))
277    (if (eq (car-safe (car (cdr index))) 'interactive)
278	(setq index (cdr index)))
279    (if (eq (car-safe (car (cdr index))) 'profile-function-prolog)
280	(setcdr index (cdr (car (cdr (car (cdr (cdr index))))))))))
281
282(defun profile-finish ()
283  "Stop profiling functions.  Clear all the settings."
284  (interactive)
285  (while profile-time-list
286    (profile-restore-fun (car (car profile-time-list)))
287    (setq profile-time-list (cdr profile-time-list)))
288  (setq profile-max-fun-name 0)
289  (setq profile-init-list nil))
290
291(provide 'profile)
292
293;;; arch-tag: 816f97e8-efff-4da2-9a95-7bc392f58b19
294;;; profile.el ends here
295