cgit.sxemacs.org Git - sxemacs/blob - src/profile.c

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