git.chise.org Git - chise/xemacs-chise.git.1/blob - src/profile.c

   1 /* Why the hell is XEmacs so fucking slow?
   2    Copyright (C) 1996 Ben Wing.
   3    Copyright (C) 1998 Free Software Foundation, Inc.
   4
   5 This file is part of XEmacs.
   6
   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
  10 later version.
  11
  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
  15 for more details.
  16
  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.  */
  21
  22 #include <config.h>
  23 #include "lisp.h"
  24
  25 #include "backtrace.h"
  26 #include "bytecode.h"
  27 #include "elhash.h"
  28 #include "hash.h"
  29
  30 #include "syssignal.h"
  31 #include "systime.h"
  32
  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
  36    somewhat useless.
  37
  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
  43    with that function.
  44
  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
  48    worth.
  49
  50
  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 */
  59
  60 struct hash_table *big_profile_table;
  61 Lisp_Object Vcall_count_profile_table;
  62
  63 int default_profiling_interval;
  64
  65 int profiling_active;
  66
  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;
  70
  71 Lisp_Object QSin_redisplay;
  72 Lisp_Object QSin_garbage_collection;
  73 Lisp_Object QSprocessing_events_at_top_level;
  74 Lisp_Object QSunknown;
  75
  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;
  81
  82 /* Increase the value of OBJ in Vcall_count_profile_table hash table.
  83    If the hash table is nil, create it first.  */
  84 void
  85 profile_increase_call_count (Lisp_Object obj)
  86 {
  87   Lisp_Object count;
  88
  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);
  92
  93   count = Fgethash (obj, Vcall_count_profile_table, Qzero);
  94   if (!INTP (count))
  95     count = Qzero;
  96   Fputhash (obj, make_int (1 + XINT (count)), Vcall_count_profile_table);
  97 }
  98
  99 static SIGTYPE
 100 sigprof_handler (int signo)
 101 {
 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)
 105     {
 106       Lisp_Object fun;
 107
 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
 111          condition case. */
 112       inside_profiling = 1;
 113
 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)
 119         {
 120           fun = *backtrace_list->function;
 121
 122           if (!GC_SYMBOLP            (fun) &&
 123               !GC_COMPILED_FUNCTIONP (fun) &&
 124               !GC_SUBRP              (fun))
 125              fun = QSunknown;
 126         }
 127       else
 128         fun = QSprocessing_events_at_top_level;
 129
 130       {
 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. */
 136         long count;
 137         CONST void *vval;
 138
 139         if (gethash (LISP_TO_VOID (fun), big_profile_table, &vval))
 140           count = (long) vval;
 141         else
 142           count = 0;
 143         count++;
 144         vval = (CONST void *) count;
 145         puthash (LISP_TO_VOID (fun), (void *) vval, big_profile_table);
 146       }
 147
 148       inside_profiling = 0;
 149     }
 150 }
 151
 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'
 155 is used.
 156
 157 You can retrieve the recorded profiling info using `get-profiling-info'.
 158
 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.
 162 */
 163        (microsecs))
 164 {
 165   /* This function can GC */
 166   int msecs;
 167   struct itimerval foo;
 168
 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);
 176
 177   if (NILP (microsecs))
 178     msecs = default_profiling_interval;
 179   else
 180     {
 181       CHECK_NATNUM (microsecs);
 182       msecs = XINT (microsecs);
 183     }
 184   if (msecs <= 0)
 185     msecs = 1000;
 186
 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);
 195   return Qnil;
 196 }
 197
 198 DEFUN ("stop-profiling", Fstop_profiling, 0, 0, 0, /*
 199 Stop profiling.
 200 */
 201        ())
 202 {
 203   /* This function does not GC */
 204   struct itimerval foo;
 205
 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);
 212   return Qnil;
 213 }
 214
 215 static Lisp_Object
 216 profile_lock_unwind (Lisp_Object ignore)
 217 {
 218   inside_profiling = 0;
 219   return Qnil;
 220 }
 221
 222 struct get_profiling_info_closure
 223 {
 224   Lisp_Object accum;
 225 };
 226
 227 static int
 228 get_profiling_info_maphash (CONST void *void_key,
 229                             void *void_val,
 230                             void *void_closure)
 231 {
 232   /* This function does not GC */
 233   Lisp_Object key;
 234   struct get_profiling_info_closure *closure
 235     = (struct get_profiling_info_closure *) void_closure;
 236   EMACS_INT val;
 237
 238   CVOID_TO_LISP (key, void_key);
 239   val = (EMACS_INT) void_val;
 240
 241   closure->accum = Fcons (Fcons (key, make_int (val)), closure->accum);
 242   return 0;
 243 }
 244
 245 DEFUN ("get-profiling-info", Fget_profiling_info, 0, 0, 0, /*
 246 Return the profiling info as an alist.
 247 */
 248        ())
 249 {
 250   /* This function does not GC */
 251   struct get_profiling_info_closure closure;
 252
 253   closure.accum = Qnil;
 254   if (big_profile_table)
 255     {
 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);
 261     }
 262   return closure.accum;
 263 }
 264
 265 struct mark_profiling_info_closure
 266 {
 267   void (*markfun) (Lisp_Object);
 268 };
 269
 270 static int
 271 mark_profiling_info_maphash (CONST void *void_key,
 272                              void *void_val,
 273                              void *void_closure)
 274 {
 275   Lisp_Object key;
 276
 277   CVOID_TO_LISP (key, void_key);
 278   (((struct mark_profiling_info_closure *) void_closure)->markfun) (key);
 279   return 0;
 280 }
 281
 282 void
 283 mark_profiling_info (void (*markfun) (Lisp_Object))
 284 {
 285   /* This function does not GC (if markfun doesn't) */
 286   struct mark_profiling_info_closure closure;
 287
 288   closure.markfun = markfun;
 289   if (big_profile_table)
 290     {
 291       inside_profiling = 1;
 292       maphash (mark_profiling_info_maphash, big_profile_table, &closure);
 293       inside_profiling = 0;
 294     }
 295 }
 296
 297 DEFUN ("clear-profiling-info", Fclear_profiling_info, 0, 0, "", /*
 298 Clear out the recorded profiling info.
 299 */
 300        ())
 301 {
 302   /* This function does not GC */
 303   if (big_profile_table)
 304     {
 305       inside_profiling = 1;
 306       clrhash (big_profile_table);
 307       inside_profiling = 0;
 308     }
 309   if (!NILP (Vcall_count_profile_table))
 310     Fclrhash (Vcall_count_profile_table);
 311   return Qnil;
 312 }
 313
 314 DEFUN ("profiling-active-p", Fprofiling_active_p, 0, 0, 0, /*
 315 Return non-nil if profiling information is currently being recorded.
 316 */
 317        ())
 318 {
 319   return profiling_active ? Qt : Qnil;
 320 }
 321
 322 void
 323 syms_of_profile (void)
 324 {
 325   DEFSUBR (Fstart_profiling);
 326   DEFSUBR (Fstop_profiling);
 327   DEFSUBR (Fget_profiling_info);
 328   DEFSUBR (Fclear_profiling_info);
 329   DEFSUBR (Fprofiling_active_p);
 330 }
 331
 332 void
 333 vars_of_profile (void)
 334 {
 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.
 340 */ );
 341   default_profiling_interval = 1000;
 342
 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).
 347 */ );
 348   Vcall_count_profile_table = Qnil;
 349
 350   inside_profiling = 0;
 351
 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);
 361 }