--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/profile.c	Mon Aug 13 11:28:15 2007 +0200
@@ -0,0 +1,353 @@
+/* Why the hell is XEmacs so fucking slow?
+   Copyright (C) 1996 Ben Wing.
+   Copyright (C) 1998 Free Software Foundation, Inc.
+
+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 "elhash.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 1 to 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 it's
+   worth.
+
+
+   Jan 1998: In addition to this, I have added code to remember call
+   counts of Lisp funcalls.  The profile_increase_call_count()
+   function is called from Ffuncall(), and serves to add data to
+   Vcall_count_profile_table.  This mechanism is much simpler and
+   independent of the SIGPROF-driven one.  It uses the Lisp allocation
+   mechanism normally, since it is not called from a handler.  It may
+   even be useful to provide a way to turn on only one profiling
+   mechanism, but I haven't done so yet.  --hniksic */
+
+static struct hash_table *big_profile_table;
+Lisp_Object Vcall_count_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;
+
+static Lisp_Object QSin_redisplay;
+static Lisp_Object QSin_garbage_collection;
+static Lisp_Object QSprocessing_events_at_top_level;
+static Lisp_Object QSunknown;
+
+/* We use inside_profiling to prevent the handler from writing to
+   the table while another routine is operating on it.  We also set
+   inside_profiling in case the timeout between signal calls is short
+   enough to catch us while we're already in there. */
+static volatile int inside_profiling;
+
+/* Increase the value of OBJ in Vcall_count_profile_table hash table.
+   If the hash table is nil, create it first.  */
+void
+profile_increase_call_count (Lisp_Object obj)
+{
+  Lisp_Object count;
+
+  if (NILP (Vcall_count_profile_table))
+    Vcall_count_profile_table =
+      make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
+
+  count = Fgethash (obj, Vcall_count_profile_table, Qzero);
+  if (!INTP (count))
+    count = Qzero;
+  Fputhash (obj, make_int (1 + XINT (count)), Vcall_count_profile_table);
+}
+
+static SIGTYPE
+sigprof_handler (int signo)
+{
+  /* Don't do anything if we are shutting down, or are doing a maphash
+     or clrhash on the table. */
+  if (!inside_profiling && !preparing_for_armageddon)
+    {
+      Lisp_Object fun;
+
+      /* If something below causes an error to be signaled, we'll
+	 not correctly reset this flag.  But we'll be in worse shape
+	 than that anyways, since we'll longjmp back to the last
+	 condition case. */
+      inside_profiling = 1;
+
+      if (profiling_redisplay_flag)
+	fun = QSin_redisplay;
+      else if (gc_in_progress)
+	fun = QSin_garbage_collection;
+      else if (backtrace_list)
+	{
+	  fun = *backtrace_list->function;
+
+	  if (!SYMBOLP	     (fun) &&
+	      !COMPILED_FUNCTIONP (fun) &&
+	      !SUBRP		     (fun))
+	     fun = QSunknown;
+	}
+      else
+	fun = QSprocessing_events_at_top_level;
+
+      {
+	/* #### see comment about memory allocation in start-profiling.
+	   Allocating memory in a signal handler is BAD BAD BAD.
+	   If you are using the non-mmap rel-alloc code, you might
+	   lose because of this.  Even worse, if the memory allocation
+	   fails, the `error' generated whacks everything hard. */
+	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);
+      }
+
+      inside_profiling = 0;
+    }
+}
+
+DEFUN ("start-profiling", Fstart_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))
+{
+  /* This function can GC */
+  int msecs;
+  struct itimerval foo;
+
+  /* #### The hash code can safely be called from a signal handler
+     except when it has to grow the hash table.  In this case, it calls
+     realloc(), which is not (in general) re-entrant.  We'll 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_hash_table (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;
+  inside_profiling = 0;
+  setitimer (ITIMER_PROF, &foo, 0);
+  return Qnil;
+}
+
+DEFUN ("stop-profiling", Fstop_profiling, 0, 0, 0, /*
+Stop profiling.
+*/
+       ())
+{
+  /* This function does not GC */
+  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;
+}
+
+static Lisp_Object
+profile_lock_unwind (Lisp_Object ignore)
+{
+  inside_profiling = 0;
+  return Qnil;
+}
+
+struct get_profiling_info_closure
+{
+  Lisp_Object accum;
+};
+
+static int
+get_profiling_info_maphash (CONST void *void_key,
+			    void *void_val,
+			    void *void_closure)
+{
+  /* This function does not GC */
+  Lisp_Object key;
+  struct get_profiling_info_closure *closure
+    = (struct get_profiling_info_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);
+  return 0;
+}
+
+DEFUN ("get-profiling-info", Fget_profiling_info, 0, 0, 0, /*
+Return the profiling info as an alist.
+*/
+       ())
+{
+  /* This function does not GC */
+  struct get_profiling_info_closure closure;
+
+  closure.accum = Qnil;
+  if (big_profile_table)
+    {
+      int count = specpdl_depth ();
+      record_unwind_protect (profile_lock_unwind, Qnil);
+      inside_profiling = 1;
+      maphash (get_profiling_info_maphash, big_profile_table, &closure);
+      unbind_to (count, Qnil);
+    }
+  return closure.accum;
+}
+
+static int
+mark_profiling_info_maphash (CONST void *void_key,
+			     void *void_val,
+			     void *void_closure)
+{
+  Lisp_Object key;
+
+  CVOID_TO_LISP (key, void_key);
+  mark_object (key);
+  return 0;
+}
+
+void
+mark_profiling_info (void)
+{
+  /* This function does not GC */
+  if (big_profile_table)
+    {
+      inside_profiling = 1;
+      maphash (mark_profiling_info_maphash, big_profile_table, 0);
+      inside_profiling = 0;
+    }
+}
+
+DEFUN ("clear-profiling-info", Fclear_profiling_info, 0, 0, "", /*
+Clear out the recorded profiling info.
+*/
+       ())
+{
+  /* This function does not GC */
+  if (big_profile_table)
+    {
+      inside_profiling = 1;
+      clrhash (big_profile_table);
+      inside_profiling = 0;
+    }
+  if (!NILP (Vcall_count_profile_table))
+    Fclrhash (Vcall_count_profile_table);
+  return Qnil;
+}
+
+DEFUN ("profiling-active-p", Fprofiling_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 (Fstart_profiling);
+  DEFSUBR (Fstop_profiling);
+  DEFSUBR (Fget_profiling_info);
+  DEFSUBR (Fclear_profiling_info);
+  DEFSUBR (Fprofiling_active_p);
+}
+
+void
+vars_of_profile (void)
+{
+  DEFVAR_INT ("default-profiling-interval", &default_profiling_interval /*
+Default CPU time in microseconds between profiling sampling.
+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;
+
+  DEFVAR_LISP ("call-count-profile-table", &Vcall_count_profile_table /*
+The table where call-count information is stored by the profiling primitives.
+This is a hash table whose keys are funcallable objects, and whose
+values are their call counts (integers).
+*/ );
+  Vcall_count_profile_table = Qnil;
+
+  inside_profiling = 0;
+
+  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);
+}