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 static 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 static Lisp_Object QSin_redisplay;
  72 static Lisp_Object QSin_garbage_collection;
  73 static Lisp_Object QSprocessing_events_at_top_level;
  74 static 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 (!SYMBOLP (fun)
 123               && !COMPILED_FUNCTIONP (fun)
 124               && !SUBRP (fun)
 125               && !CONSP (fun))
 126              fun = QSunknown;
 127         }
 128       else
 129         fun = QSprocessing_events_at_top_level;
 130
 131       {
 132         /* #### see comment about memory allocation in start-profiling.
 133            Allocating memory in a signal handler is BAD BAD BAD.
 134            If you are using the non-mmap rel-alloc code, you might
 135            lose because of this.  Even worse, if the memory allocation
 136            fails, the `error' generated whacks everything hard. */
 137         long count;
 138         CONST void *vval;
 139
 140         if (gethash (LISP_TO_VOID (fun), big_profile_table, &vval))
 141           count = (long) vval;
 142         else
 143           count = 0;
 144         count++;
 145         vval = (CONST void *) count;
 146         puthash (LISP_TO_VOID (fun), (void *) vval, big_profile_table);
 147       }
 148
 149       inside_profiling = 0;
 150     }
 151 }
 152
 153 DEFUN ("start-profiling", Fstart_profiling, 0, 1, 0, /*
 154 Start profiling, with profile queries every MICROSECS.
 155 If MICROSECS is nil or omitted, the value of `default-profiling-interval'
 156 is used.
 157
 158 You can retrieve the recorded profiling info using `get-profiling-info'.
 159
 160 Starting and stopping profiling does not clear the currently recorded
 161 info.  Thus you can start and stop as many times as you want and everything
 162 will be properly accumulated.
 163 */
 164        (microsecs))
 165 {
 166   /* This function can GC */
 167   int msecs;
 168   struct itimerval foo;
 169
 170   /* #### The hash code can safely be called from a signal handler
 171      except when it has to grow the hash table.  In this case, it calls
 172      realloc(), which is not (in general) re-entrant.  We'll just be
 173      sleazy and make the table large enough that it (hopefully) won't
 174      need to be realloc()ed. */
 175   if (!big_profile_table)
 176     big_profile_table = make_hash_table (10000);
 177
 178   if (NILP (microsecs))
 179     msecs = default_profiling_interval;
 180   else
 181     {
 182       CHECK_NATNUM (microsecs);
 183       msecs = XINT (microsecs);
 184     }
 185   if (msecs <= 0)
 186     msecs = 1000;
 187
 188   signal (SIGPROF, sigprof_handler);
 189   foo.it_value.tv_sec = 0;
 190   foo.it_value.tv_usec = msecs;
 191   EMACS_NORMALIZE_TIME (foo.it_value);
 192   foo.it_interval = foo.it_value;
 193   profiling_active = 1;
 194   inside_profiling = 0;
 195   setitimer (ITIMER_PROF, &foo, 0);
 196   return Qnil;
 197 }
 198
 199 DEFUN ("stop-profiling", Fstop_profiling, 0, 0, 0, /*
 200 Stop profiling.
 201 */
 202        ())
 203 {
 204   /* This function does not GC */
 205   struct itimerval foo;
 206
 207   foo.it_value.tv_sec = 0;
 208   foo.it_value.tv_usec = 0;
 209   foo.it_interval = foo.it_value;
 210   setitimer (ITIMER_PROF, &foo, 0);
 211   profiling_active = 0;
 212   signal (SIGPROF, fatal_error_signal);
 213   return Qnil;
 214 }
 215
 216 static Lisp_Object
 217 profile_lock_unwind (Lisp_Object ignore)
 218 {
 219   inside_profiling = 0;
 220   return Qnil;
 221 }
 222
 223 struct get_profiling_info_closure
 224 {
 225   Lisp_Object accum;
 226 };
 227
 228 static int
 229 get_profiling_info_maphash (CONST void *void_key,
 230                             void *void_val,
 231                             void *void_closure)
 232 {
 233   /* This function does not GC */
 234   Lisp_Object key;
 235   struct get_profiling_info_closure *closure
 236     = (struct get_profiling_info_closure *) void_closure;
 237   EMACS_INT val;
 238
 239   CVOID_TO_LISP (key, void_key);
 240   val = (EMACS_INT) void_val;
 241
 242   closure->accum = Fcons (Fcons (key, make_int (val)), closure->accum);
 243   return 0;
 244 }
 245
 246 DEFUN ("get-profiling-info", Fget_profiling_info, 0, 0, 0, /*
 247 Return the profiling info as an alist.
 248 */
 249        ())
 250 {
 251   /* This function does not GC */
 252   struct get_profiling_info_closure closure;
 253
 254   closure.accum = Qnil;
 255   if (big_profile_table)
 256     {
 257       int count = specpdl_depth ();
 258       record_unwind_protect (profile_lock_unwind, Qnil);
 259       inside_profiling = 1;
 260       maphash (get_profiling_info_maphash, big_profile_table, &closure);
 261       unbind_to (count, Qnil);
 262     }
 263   return closure.accum;
 264 }
 265
 266 static int
 267 mark_profiling_info_maphash (CONST void *void_key,
 268                              void *void_val,
 269                              void *void_closure)
 270 {
 271   Lisp_Object key;
 272
 273   CVOID_TO_LISP (key, void_key);
 274   mark_object (key);
 275   return 0;
 276 }
 277
 278 void
 279 mark_profiling_info (void)
 280 {
 281   /* This function does not GC */
 282   if (big_profile_table)
 283     {
 284       inside_profiling = 1;
 285       maphash (mark_profiling_info_maphash, big_profile_table, 0);
 286       inside_profiling = 0;
 287     }
 288 }
 289
 290 DEFUN ("clear-profiling-info", Fclear_profiling_info, 0, 0, "", /*
 291 Clear out the recorded profiling info.
 292 */
 293        ())
 294 {
 295   /* This function does not GC */
 296   if (big_profile_table)
 297     {
 298       inside_profiling = 1;
 299       clrhash (big_profile_table);
 300       inside_profiling = 0;
 301     }
 302   if (!NILP (Vcall_count_profile_table))
 303     Fclrhash (Vcall_count_profile_table);
 304   return Qnil;
 305 }
 306
 307 DEFUN ("profiling-active-p", Fprofiling_active_p, 0, 0, 0, /*
 308 Return non-nil if profiling information is currently being recorded.
 309 */
 310        ())
 311 {
 312   return profiling_active ? Qt : Qnil;
 313 }
 314
 315 void
 316 syms_of_profile (void)
 317 {
 318   DEFSUBR (Fstart_profiling);
 319   DEFSUBR (Fstop_profiling);
 320   DEFSUBR (Fget_profiling_info);
 321   DEFSUBR (Fclear_profiling_info);
 322   DEFSUBR (Fprofiling_active_p);
 323 }
 324
 325 void
 326 vars_of_profile (void)
 327 {
 328   DEFVAR_INT ("default-profiling-interval", &default_profiling_interval /*
 329 Default CPU time in microseconds between profiling sampling.
 330 Used when the argument to `start-profiling' is nil or omitted.
 331 Note that the time in question is CPU time (when the program is executing
 332 or the kernel is executing on behalf of the program) and not real time.
 333 */ );
 334   default_profiling_interval = 1000;
 335
 336   DEFVAR_LISP ("call-count-profile-table", &Vcall_count_profile_table /*
 337 The table where call-count information is stored by the profiling primitives.
 338 This is a hash table whose keys are funcallable objects, and whose
 339 values are their call counts (integers).
 340 */ );
 341   Vcall_count_profile_table = Qnil;
 342
 343   inside_profiling = 0;
 344
 345   QSin_redisplay = build_string ("(in redisplay)");
 346   staticpro (&QSin_redisplay);
 347   QSin_garbage_collection = build_string ("(in garbage collection)");
 348   staticpro (&QSin_garbage_collection);
 349   QSunknown = build_string ("(unknown)");
 350   staticpro (&QSunknown);
 351   QSprocessing_events_at_top_level =
 352     build_string ("(processing events at top level)");
 353   staticpro (&QSprocessing_events_at_top_level);
 354 }