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 #ifndef HAVE_SETITIMER
  34 #error Sorry charlie.  We need a scalpel and all we have is a lawnmower.
  35 #endif
  36
  37 /* We implement our own profiling scheme so that we can determine
  38    things like which Lisp functions are occupying the most time.  Any
  39    standard OS-provided profiling works on C functions, which is
  40    somewhat useless.
  41
  42    The basic idea is simple.  We set a profiling timer using setitimer
  43    (ITIMER_PROF), which generates a SIGPROF every so often.  (This
  44    runs not in real time but rather when the process is executing or
  45    the system is running on behalf of the process.) When the signal
  46    goes off, we see what we're in, and add 1 to the count associated
  47    with that function.
  48
  49    It would be nice to use the Lisp allocation mechanism etc. to keep
  50    track of the profiling information, but we can't because that's not
  51    safe, and trying to make it safe would be much more work than it's
  52    worth.
  53
  54
  55    Jan 1998: In addition to this, I have added code to remember call
  56    counts of Lisp funcalls.  The profile_increase_call_count()
  57    function is called from Ffuncall(), and serves to add data to
  58    Vcall_count_profile_table.  This mechanism is much simpler and
  59    independent of the SIGPROF-driven one.  It uses the Lisp allocation
  60    mechanism normally, since it is not called from a handler.  It may
  61    even be useful to provide a way to turn on only one profiling
  62    mechanism, but I haven't done so yet.  --hniksic */
  63
  64 static struct hash_table *big_profile_table;
  65 Lisp_Object Vcall_count_profile_table;
  66
  67 Fixnum default_profiling_interval;
  68
  69 int profiling_active;
  70
  71 /* The normal flag in_display is used as a critical-section flag
  72    and is not set the whole time we're in redisplay. */
  73 int profiling_redisplay_flag;
  74
  75 static Lisp_Object QSin_redisplay;
  76 static Lisp_Object QSin_garbage_collection;
  77 static Lisp_Object QSprocessing_events_at_top_level;
  78 static Lisp_Object QSunknown;
  79
  80 /* We use inside_profiling to prevent the handler from writing to
  81    the table while another routine is operating on it.  We also set
  82    inside_profiling in case the timeout between signal calls is short
  83    enough to catch us while we're already in there. */
  84 static volatile int inside_profiling;
  85
  86 /* Increase the value of OBJ in Vcall_count_profile_table hash table.
  87    If the hash table is nil, create it first.  */
  88 void
  89 profile_increase_call_count (Lisp_Object obj)
  90 {
  91   Lisp_Object count;
  92
  93   if (NILP (Vcall_count_profile_table))
  94     Vcall_count_profile_table =
  95       make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
  96
  97   count = Fgethash (obj, Vcall_count_profile_table, Qzero);
  98   if (!INTP (count))
  99     count = Qzero;
 100   Fputhash (obj, make_int (1 + XINT (count)), Vcall_count_profile_table);
 101 }
 102
 103 static SIGTYPE
 104 sigprof_handler (int signo)
 105 {
 106   /* Don't do anything if we are shutting down, or are doing a maphash
 107      or clrhash on the table. */
 108   if (!inside_profiling && !preparing_for_armageddon)
 109     {
 110       Lisp_Object fun;
 111
 112       /* If something below causes an error to be signaled, we'll
 113          not correctly reset this flag.  But we'll be in worse shape
 114          than that anyways, since we'll longjmp back to the last
 115          condition case. */
 116       inside_profiling = 1;
 117
 118       if (profiling_redisplay_flag)
 119         fun = QSin_redisplay;
 120       else if (gc_in_progress)
 121         fun = QSin_garbage_collection;
 122       else if (backtrace_list)
 123         {
 124           fun = *backtrace_list->function;
 125
 126           if (!SYMBOLP (fun)
 127               && !COMPILED_FUNCTIONP (fun)
 128               && !SUBRP (fun)
 129               && !CONSP (fun))
 130              fun = QSunknown;
 131         }
 132       else
 133         fun = QSprocessing_events_at_top_level;
 134
 135       {
 136         /* #### see comment about memory allocation in start-profiling.
 137            Allocating memory in a signal handler is BAD BAD BAD.
 138            If you are using the non-mmap rel-alloc code, you might
 139            lose because of this.  Even worse, if the memory allocation
 140            fails, the `error' generated whacks everything hard. */
 141         long count;
 142         const void *vval;
 143
 144         if (gethash (LISP_TO_VOID (fun), big_profile_table, &vval))
 145           count = (long) vval;
 146         else
 147           count = 0;
 148         count++;
 149         vval = (const void *) count;
 150         puthash (LISP_TO_VOID (fun), (void *) vval, big_profile_table);
 151       }
 152
 153       inside_profiling = 0;
 154     }
 155 }
 156
 157 DEFUN ("start-profiling", Fstart_profiling, 0, 1, 0, /*
 158 Start profiling, with profile queries every MICROSECS.
 159 If MICROSECS is nil or omitted, the value of `default-profiling-interval'
 160 is used.
 161
 162 You can retrieve the recorded profiling info using `get-profiling-info'.
 163
 164 Starting and stopping profiling does not clear the currently recorded
 165 info.  Thus you can start and stop as many times as you want and everything
 166 will be properly accumulated.
 167 */
 168        (microsecs))
 169 {
 170   /* This function can GC */
 171   int msecs;
 172   struct itimerval foo;
 173
 174   /* #### The hash code can safely be called from a signal handler
 175      except when it has to grow the hash table.  In this case, it calls
 176      realloc(), which is not (in general) re-entrant.  We'll just be
 177      sleazy and make the table large enough that it (hopefully) won't
 178      need to be realloc()ed. */
 179   if (!big_profile_table)
 180     big_profile_table = make_hash_table (10000);
 181
 182   if (NILP (microsecs))
 183     msecs = default_profiling_interval;
 184   else
 185     {
 186       CHECK_NATNUM (microsecs);
 187       msecs = XINT (microsecs);
 188     }
 189   if (msecs <= 0)
 190     msecs = 1000;
 191
 192   signal (SIGPROF, sigprof_handler);
 193   foo.it_value.tv_sec = 0;
 194   foo.it_value.tv_usec = msecs;
 195   EMACS_NORMALIZE_TIME (foo.it_value);
 196   foo.it_interval = foo.it_value;
 197   profiling_active = 1;
 198   inside_profiling = 0;
 199   qxe_setitimer (ITIMER_PROF, &foo, 0);
 200   return Qnil;
 201 }
 202
 203 DEFUN ("stop-profiling", Fstop_profiling, 0, 0, 0, /*
 204 Stop profiling.
 205 */
 206        ())
 207 {
 208   /* This function does not GC */
 209   struct itimerval foo;
 210
 211   foo.it_value.tv_sec = 0;
 212   foo.it_value.tv_usec = 0;
 213   foo.it_interval = foo.it_value;
 214   qxe_setitimer (ITIMER_PROF, &foo, 0);
 215   profiling_active = 0;
 216   signal (SIGPROF, fatal_error_signal);
 217   return Qnil;
 218 }
 219
 220 static Lisp_Object
 221 profile_lock_unwind (Lisp_Object ignore)
 222 {
 223   inside_profiling = 0;
 224   return Qnil;
 225 }
 226
 227 struct get_profiling_info_closure
 228 {
 229   Lisp_Object accum;
 230 };
 231
 232 static int
 233 get_profiling_info_maphash (const void *void_key,
 234                             void *void_val,
 235                             void *void_closure)
 236 {
 237   /* This function does not GC */
 238   Lisp_Object key;
 239   struct get_profiling_info_closure *closure
 240     = (struct get_profiling_info_closure *) void_closure;
 241   EMACS_INT val;
 242
 243   CVOID_TO_LISP (key, void_key);
 244   val = (EMACS_INT) void_val;
 245
 246   closure->accum = Fcons (Fcons (key, make_int (val)), closure->accum);
 247   return 0;
 248 }
 249
 250 DEFUN ("get-profiling-info", Fget_profiling_info, 0, 0, 0, /*
 251 Return the profiling info as an alist.
 252 */
 253        ())
 254 {
 255   /* This function does not GC */
 256   struct get_profiling_info_closure closure;
 257
 258   closure.accum = Qnil;
 259   if (big_profile_table)
 260     {
 261       int count = specpdl_depth ();
 262       record_unwind_protect (profile_lock_unwind, Qnil);
 263       inside_profiling = 1;
 264       maphash (get_profiling_info_maphash, big_profile_table, &closure);
 265       unbind_to (count, Qnil);
 266     }
 267   return closure.accum;
 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   mark_object (key);
 279   return 0;
 280 }
 281
 282 void
 283 mark_profiling_info (void)
 284 {
 285   /* This function does not GC */
 286   if (big_profile_table)
 287     {
 288       inside_profiling = 1;
 289       maphash (mark_profiling_info_maphash, big_profile_table, 0);
 290       inside_profiling = 0;
 291     }
 292 }
 293
 294 DEFUN ("clear-profiling-info", Fclear_profiling_info, 0, 0, "", /*
 295 Clear out the recorded profiling info.
 296 */
 297        ())
 298 {
 299   /* This function does not GC */
 300   if (big_profile_table)
 301     {
 302       inside_profiling = 1;
 303       clrhash (big_profile_table);
 304       inside_profiling = 0;
 305     }
 306   if (!NILP (Vcall_count_profile_table))
 307     Fclrhash (Vcall_count_profile_table);
 308   return Qnil;
 309 }
 310
 311 DEFUN ("profiling-active-p", Fprofiling_active_p, 0, 0, 0, /*
 312 Return non-nil if profiling information is currently being recorded.
 313 */
 314        ())
 315 {
 316   return profiling_active ? Qt : Qnil;
 317 }
 318
 319 void
 320 syms_of_profile (void)
 321 {
 322   DEFSUBR (Fstart_profiling);
 323   DEFSUBR (Fstop_profiling);
 324   DEFSUBR (Fget_profiling_info);
 325   DEFSUBR (Fclear_profiling_info);
 326   DEFSUBR (Fprofiling_active_p);
 327 }
 328
 329 void
 330 vars_of_profile (void)
 331 {
 332   DEFVAR_INT ("default-profiling-interval", &default_profiling_interval /*
 333 Default CPU time in microseconds between profiling sampling.
 334 Used when the argument to `start-profiling' is nil or omitted.
 335 Note that the time in question is CPU time (when the program is executing
 336 or the kernel is executing on behalf of the program) and not real time.
 337 */ );
 338   default_profiling_interval = 1000;
 339
 340   DEFVAR_LISP ("call-count-profile-table", &Vcall_count_profile_table /*
 341 The table where call-count information is stored by the profiling primitives.
 342 This is a hash table whose keys are funcallable objects, and whose
 343 values are their call counts (integers).
 344 */ );
 345   Vcall_count_profile_table = Qnil;
 346
 347   inside_profiling = 0;
 348
 349   QSin_redisplay = build_string ("(in redisplay)");
 350   staticpro (&QSin_redisplay);
 351   QSin_garbage_collection = build_string ("(in garbage collection)");
 352   staticpro (&QSin_garbage_collection);
 353   QSunknown = build_string ("(unknown)");
 354   staticpro (&QSunknown);
 355   QSprocessing_events_at_top_level =
 356     build_string ("(processing events at top level)");
 357   staticpro (&QSprocessing_events_at_top_level);
 358 }