--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/profile.c	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,274 @@
+/* Why the hell is XEmacs so fucking slow?
+   Copyright (C) 1996 Ben Wing.
+
+This file is part of XEmacs.
+
+XEmacs is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2, or (at your option) any
+later version.
+
+XEmacs is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with XEmacs; see the file COPYING.  If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include <config.h>
+#include "lisp.h"
+
+#include "backtrace.h"
+#include "bytecode.h"
+#include "hash.h"
+
+#include "syssignal.h"
+#include "systime.h"
+
+/*
+
+We implement our own profiling scheme so that we can determine things
+like which Lisp functions are occupying the most time.  Any standard
+OS-provided profiling works on C functions, which is somewhat useless.
+
+The basic idea is simple.  We set a profiling timer using
+setitimer (ITIMER_PROF), which generates a SIGPROF every so often.
+\(This runs not in real time but rather when the process is executing
+or the system is running on behalf of the process.) When the signal
+goes off, we see what we're in, and add by 1 the count associated with
+that function.
+
+It would be nice to use the Lisp allocation mechanism etc. to keep
+track of the profiling information, but we can't because that's not
+safe, and trying to make it safe would be much more work than is
+worth.
+
+*/
+
+c_hashtable big_profile_table;
+
+int default_profiling_interval;
+
+int profiling_active;
+
+/* The normal flag in_display is used as a critical-section flag
+   and is not set the whole time we're in redisplay. */
+int profiling_redisplay_flag;
+
+Lisp_Object QSin_redisplay;
+Lisp_Object QSin_garbage_collection;
+Lisp_Object QSprocessing_events_at_top_level;
+Lisp_Object QSunknown;
+
+static SIGTYPE
+sigprof_handler (int signo)
+{
+  Lisp_Object fun;
+
+  if (profiling_redisplay_flag)
+    fun = QSin_redisplay;
+  else if (gc_in_progress)
+    fun = QSin_garbage_collection;
+  else if (backtrace_list)
+    {
+      fun = *backtrace_list->function;
+
+      XUNMARK (fun);
+      if (!GC_SYMBOLP (fun) && !GC_COMPILED_FUNCTIONP (fun))
+        fun = QSunknown;
+    }
+  else
+    fun = QSprocessing_events_at_top_level;
+
+  {
+    long count;
+    CONST void *vval;
+    
+    if (gethash (LISP_TO_VOID (fun), big_profile_table, &vval))
+      count = (long) vval;
+    else
+      count = 0;
+    count++;
+    vval = (CONST void *) count;
+    puthash (LISP_TO_VOID (fun), (void *) vval, big_profile_table);
+  }
+}
+
+DEFUN ("start-profiling", Fstart_profiling, Sstart_profiling, 0, 1, 0 /*
+Start profiling, with profile queries every MICROSECS.
+If MICROSECS is nil or omitted, the value of `default-profiling-interval'
+is used.
+
+You can retrieve the recorded profiling info using `get-profiling-info'.
+
+Starting and stopping profiling does not clear the currently recorded
+info.  Thus you can start and stop as many times as you want and everything
+will be properly accumulated.  
+*/ )
+  (microsecs)
+     Lisp_Object microsecs;
+{
+  int msecs;
+  struct itimerval foo;
+
+  /* #### The hash code can safely be called from a signal handler
+     except when it has to grow the hashtable.  In this case, it calls
+     realloc(), which is not (in general) re-entrant.  We just be
+     sleazy and make the table large enough that it (hopefully) won't
+     need to be realloc()ed. */
+  if (!big_profile_table)
+    big_profile_table = make_hashtable (10000);
+  if (NILP (microsecs))
+    msecs = default_profiling_interval;
+  else
+    {
+      CHECK_NATNUM (microsecs);
+      msecs = XINT (microsecs);
+    }
+  if (msecs <= 0)
+    msecs = 1000;
+
+  signal (SIGPROF, sigprof_handler);
+  foo.it_value.tv_sec = 0;
+  foo.it_value.tv_usec = msecs;
+  EMACS_NORMALIZE_TIME (foo.it_value);
+  foo.it_interval = foo.it_value;
+  profiling_active = 1;
+  setitimer (ITIMER_PROF, &foo, 0);
+  return Qnil;
+}
+
+DEFUN ("stop-profiling", Fstop_profiling, Sstop_profiling, 0, 0, 0 /*
+Stop profiling.
+*/ )
+  ()
+{
+  struct itimerval foo;
+
+  foo.it_value.tv_sec = 0;
+  foo.it_value.tv_usec = 0;
+  foo.it_interval = foo.it_value;
+  setitimer (ITIMER_PROF, &foo, 0);
+  profiling_active = 0;
+  signal (SIGPROF, fatal_error_signal);
+  return Qnil;
+}
+
+struct get_profiling_info_closure
+{
+  Lisp_Object accum;
+};
+
+static void
+get_profiling_info_maphash (CONST void *void_key,
+			    void *void_val,
+			    void *void_closure)
+{
+  /* This function can GC */
+  Lisp_Object key;
+  struct get_profiling_info_closure *closure = void_closure;
+  EMACS_INT val;
+
+  CVOID_TO_LISP (key, void_key);
+  val = (EMACS_INT) void_val;
+
+  closure->accum = Fcons (Fcons (key, make_int (val)),
+			  closure->accum);
+}
+
+DEFUN ("get-profiling-info", Fget_profiling_info, Sget_profiling_info,
+       0, 0, 0 /*
+Return the profiling info as an alist.
+*/ )
+  ()
+{
+  struct get_profiling_info_closure closure;
+
+  closure.accum = Qnil;
+  if (big_profile_table)
+    maphash (get_profiling_info_maphash, big_profile_table, &closure);
+  return closure.accum;
+}
+
+struct mark_profiling_info_closure
+{
+  void (*markfun) (Lisp_Object);
+};
+
+static void
+mark_profiling_info_maphash (CONST void *void_key,
+			     void *void_val,
+			     void *void_closure)
+{
+  /* This function can GC */
+  Lisp_Object key;
+  struct mark_profiling_info_closure *closure = void_closure;
+
+  CVOID_TO_LISP (key, void_key);
+  (closure->markfun) (key);
+}
+
+void
+mark_profiling_info (void (*markfun) (Lisp_Object))
+{
+  struct mark_profiling_info_closure closure;
+
+  closure.markfun = markfun;
+  if (big_profile_table)
+    maphash (mark_profiling_info_maphash, big_profile_table, &closure);
+}
+
+DEFUN ("clear-profiling-info", Fclear_profiling_info, Sclear_profiling_info,
+       0, 0, 0 /*
+Clear out the recorded profiling info.
+*/ )
+  ()
+{
+  if (big_profile_table)
+    clrhash (big_profile_table);
+  return Qnil;
+}
+
+DEFUN ("profiling-active-p", Fprofiling_active_p, Sprofiling_active_p,
+       0, 0, 0 /*
+Return non-nil if profiling information is currently being recorded.
+*/ )
+  ()
+{
+  return profiling_active ? Qt : Qnil;
+}
+
+void
+syms_of_profile (void)
+{
+  defsubr (&Sstart_profiling);
+  defsubr (&Sstop_profiling);
+  defsubr (&Sget_profiling_info);
+  defsubr (&Sclear_profiling_info);
+  defsubr (&Sprofiling_active_p);
+}
+
+void
+vars_of_profile (void)
+{
+  DEFVAR_INT ("default-profiling-interval", &default_profiling_interval /*
+Default time in microseconds between profiling queries.
+Used when the argument to `start-profiling' is nil or omitted.
+Note that the time in question is CPU time (when the program is executing
+or the kernel is executing on behalf of the program) and not real time.
+*/ );
+  default_profiling_interval = 1000;
+
+  QSin_redisplay = build_string ("(in redisplay)");
+  staticpro (&QSin_redisplay);
+  QSin_garbage_collection = build_string ("(in garbage collection)");
+  staticpro (&QSin_garbage_collection);
+  QSunknown = build_string ("(unknown)");
+  staticpro (&QSunknown);
+  QSprocessing_events_at_top_level =
+    build_string ("(processing events at top level)");
+  staticpro (&QSprocessing_events_at_top_level);
+}