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