1 /* Why the hell is XEmacs so fucking slow?
2 Copyright (C) 1996 Ben Wing.
3 Copyright (C) 1998 Free Software Foundation, Inc.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
25 #include "backtrace.h"
30 #include "syssignal.h"
33 /* We implement our own profiling scheme so that we can determine
34 things like which Lisp functions are occupying the most time. Any
35 standard OS-provided profiling works on C functions, which is
38 The basic idea is simple. We set a profiling timer using setitimer
39 (ITIMER_PROF), which generates a SIGPROF every so often. (This
40 runs not in real time but rather when the process is executing or
41 the system is running on behalf of the process.) When the signal
42 goes off, we see what we're in, and add 1 to the count associated
45 It would be nice to use the Lisp allocation mechanism etc. to keep
46 track of the profiling information, but we can't because that's not
47 safe, and trying to make it safe would be much more work than it's
51 Jan 1998: In addition to this, I have added code to remember call
52 counts of Lisp funcalls. The profile_increase_call_count()
53 function is called from Ffuncall(), and serves to add data to
54 Vcall_count_profile_table. This mechanism is much simpler and
55 independent of the SIGPROF-driven one. It uses the Lisp allocation
56 mechanism normally, since it is not called from a handler. It may
57 even be useful to provide a way to turn on only one profiling
58 mechanism, but I haven't done so yet. --hniksic */
60 struct hash_table *big_profile_table;
61 Lisp_Object Vcall_count_profile_table;
63 int default_profiling_interval;
67 /* The normal flag in_display is used as a critical-section flag
68 and is not set the whole time we're in redisplay. */
69 int profiling_redisplay_flag;
71 Lisp_Object QSin_redisplay;
72 Lisp_Object QSin_garbage_collection;
73 Lisp_Object QSprocessing_events_at_top_level;
74 Lisp_Object QSunknown;
76 /* We use inside_profiling to prevent the handler from writing to
77 the table while another routine is operating on it. We also set
78 inside_profiling in case the timeout between signal calls is short
79 enough to catch us while we're already in there. */
80 static volatile int inside_profiling;
82 /* Increase the value of OBJ in Vcall_count_profile_table hash table.
83 If the hash table is nil, create it first. */
85 profile_increase_call_count (Lisp_Object obj)
89 if (NILP (Vcall_count_profile_table))
90 Vcall_count_profile_table =
91 make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
93 count = Fgethash (obj, Vcall_count_profile_table, Qzero);
96 Fputhash (obj, make_int (1 + XINT (count)), Vcall_count_profile_table);
100 sigprof_handler (int signo)
102 /* Don't do anything if we are shutting down, or are doing a maphash
103 or clrhash on the table. */
104 if (!inside_profiling && !preparing_for_armageddon)
108 /* If something below causes an error to be signaled, we'll
109 not correctly reset this flag. But we'll be in worse shape
110 than that anyways, since we'll longjmp back to the last
112 inside_profiling = 1;
114 if (profiling_redisplay_flag)
115 fun = QSin_redisplay;
116 else if (gc_in_progress)
117 fun = QSin_garbage_collection;
118 else if (backtrace_list)
120 fun = *backtrace_list->function;
122 if (!GC_SYMBOLP (fun) &&
123 !GC_COMPILED_FUNCTIONP (fun) &&
128 fun = QSprocessing_events_at_top_level;
131 /* #### see comment about memory allocation in start-profiling.
132 Allocating memory in a signal handler is BAD BAD BAD.
133 If you are using the non-mmap rel-alloc code, you might
134 lose because of this. Even worse, if the memory allocation
135 fails, the `error' generated whacks everything hard. */
139 if (gethash (LISP_TO_VOID (fun), big_profile_table, &vval))
144 vval = (CONST void *) count;
145 puthash (LISP_TO_VOID (fun), (void *) vval, big_profile_table);
148 inside_profiling = 0;
152 DEFUN ("start-profiling", Fstart_profiling, 0, 1, 0, /*
153 Start profiling, with profile queries every MICROSECS.
154 If MICROSECS is nil or omitted, the value of `default-profiling-interval'
157 You can retrieve the recorded profiling info using `get-profiling-info'.
159 Starting and stopping profiling does not clear the currently recorded
160 info. Thus you can start and stop as many times as you want and everything
161 will be properly accumulated.
165 /* This function can GC */
167 struct itimerval foo;
169 /* #### The hash code can safely be called from a signal handler
170 except when it has to grow the hash table. In this case, it calls
171 realloc(), which is not (in general) re-entrant. We'll just be
172 sleazy and make the table large enough that it (hopefully) won't
173 need to be realloc()ed. */
174 if (!big_profile_table)
175 big_profile_table = make_hash_table (10000);
177 if (NILP (microsecs))
178 msecs = default_profiling_interval;
181 CHECK_NATNUM (microsecs);
182 msecs = XINT (microsecs);
187 signal (SIGPROF, sigprof_handler);
188 foo.it_value.tv_sec = 0;
189 foo.it_value.tv_usec = msecs;
190 EMACS_NORMALIZE_TIME (foo.it_value);
191 foo.it_interval = foo.it_value;
192 profiling_active = 1;
193 inside_profiling = 0;
194 setitimer (ITIMER_PROF, &foo, 0);
198 DEFUN ("stop-profiling", Fstop_profiling, 0, 0, 0, /*
203 /* This function does not GC */
204 struct itimerval foo;
206 foo.it_value.tv_sec = 0;
207 foo.it_value.tv_usec = 0;
208 foo.it_interval = foo.it_value;
209 setitimer (ITIMER_PROF, &foo, 0);
210 profiling_active = 0;
211 signal (SIGPROF, fatal_error_signal);
216 profile_lock_unwind (Lisp_Object ignore)
218 inside_profiling = 0;
222 struct get_profiling_info_closure
228 get_profiling_info_maphash (CONST void *void_key,
232 /* This function does not GC */
234 struct get_profiling_info_closure *closure
235 = (struct get_profiling_info_closure *) void_closure;
238 CVOID_TO_LISP (key, void_key);
239 val = (EMACS_INT) void_val;
241 closure->accum = Fcons (Fcons (key, make_int (val)), closure->accum);
245 DEFUN ("get-profiling-info", Fget_profiling_info, 0, 0, 0, /*
246 Return the profiling info as an alist.
250 /* This function does not GC */
251 struct get_profiling_info_closure closure;
253 closure.accum = Qnil;
254 if (big_profile_table)
256 int count = specpdl_depth ();
257 record_unwind_protect (profile_lock_unwind, Qnil);
258 inside_profiling = 1;
259 maphash (get_profiling_info_maphash, big_profile_table, &closure);
260 unbind_to (count, Qnil);
262 return closure.accum;
265 struct mark_profiling_info_closure
267 void (*markfun) (Lisp_Object);
271 mark_profiling_info_maphash (CONST void *void_key,
277 CVOID_TO_LISP (key, void_key);
278 (((struct mark_profiling_info_closure *) void_closure)->markfun) (key);
283 mark_profiling_info (void (*markfun) (Lisp_Object))
285 /* This function does not GC (if markfun doesn't) */
286 struct mark_profiling_info_closure closure;
288 closure.markfun = markfun;
289 if (big_profile_table)
291 inside_profiling = 1;
292 maphash (mark_profiling_info_maphash, big_profile_table, &closure);
293 inside_profiling = 0;
297 DEFUN ("clear-profiling-info", Fclear_profiling_info, 0, 0, "", /*
298 Clear out the recorded profiling info.
302 /* This function does not GC */
303 if (big_profile_table)
305 inside_profiling = 1;
306 clrhash (big_profile_table);
307 inside_profiling = 0;
309 if (!NILP (Vcall_count_profile_table))
310 Fclrhash (Vcall_count_profile_table);
314 DEFUN ("profiling-active-p", Fprofiling_active_p, 0, 0, 0, /*
315 Return non-nil if profiling information is currently being recorded.
319 return profiling_active ? Qt : Qnil;
323 syms_of_profile (void)
325 DEFSUBR (Fstart_profiling);
326 DEFSUBR (Fstop_profiling);
327 DEFSUBR (Fget_profiling_info);
328 DEFSUBR (Fclear_profiling_info);
329 DEFSUBR (Fprofiling_active_p);
333 vars_of_profile (void)
335 DEFVAR_INT ("default-profiling-interval", &default_profiling_interval /*
336 Default CPU time in microseconds between profiling sampling.
337 Used when the argument to `start-profiling' is nil or omitted.
338 Note that the time in question is CPU time (when the program is executing
339 or the kernel is executing on behalf of the program) and not real time.
341 default_profiling_interval = 1000;
343 DEFVAR_LISP ("call-count-profile-table", &Vcall_count_profile_table /*
344 The table where call-count information is stored by the profiling primitives.
345 This is a hash table whose keys are funcallable objects, and whose
346 values are their call counts (integers).
348 Vcall_count_profile_table = Qnil;
350 inside_profiling = 0;
352 QSin_redisplay = build_string ("(in redisplay)");
353 staticpro (&QSin_redisplay);
354 QSin_garbage_collection = build_string ("(in garbage collection)");
355 staticpro (&QSin_garbage_collection);
356 QSunknown = build_string ("(unknown)");
357 staticpro (&QSunknown);
358 QSprocessing_events_at_top_level =
359 build_string ("(processing events at top level)");
360 staticpro (&QSprocessing_events_at_top_level);