diff src/profile.c @ 116:9f59509498e1 r20-1b10

Import from CVS: tag r20-1b10
author cvs
date Mon, 13 Aug 2007 09:23:06 +0200
parents 131b0175ea99
children 538048ae2ab8
line wrap: on
line diff
--- a/src/profile.c	Mon Aug 13 09:21:56 2007 +0200
+++ b/src/profile.c	Mon Aug 13 09:23:06 2007 +0200
@@ -63,38 +63,63 @@
 Lisp_Object QSprocessing_events_at_top_level;
 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. */
+volatile static int inside_profiling;
+
 static SIGTYPE
 sigprof_handler (int signo)
 {
-  Lisp_Object fun;
+  /* 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 (profiling_redisplay_flag)
-    fun = QSin_redisplay;
-  else if (gc_in_progress)
-    fun = QSin_garbage_collection;
-  else if (backtrace_list)
-    {
-      fun = *backtrace_list->function;
+	  /* #### dmoore - why do we need to unmark it, we aren't in GC. */
+	  XUNMARK (fun);
+	  if (!GC_SYMBOLP (fun) && !GC_COMPILED_FUNCTIONP (fun))
+	    fun = QSunknown;
+	}
+      else
+	fun = QSprocessing_events_at_top_level;
 
-      XUNMARK (fun);
-      if (!GC_SYMBOLP (fun) && !GC_COMPILED_FUNCTIONP (fun))
-        fun = QSunknown;
+      {
+	/* #### 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;
     }
-  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, 0, 1, 0, /*
@@ -110,6 +135,7 @@
 */
        (microsecs))
 {
+  /* This function can GC */
   int msecs;
   struct itimerval foo;
 
@@ -136,6 +162,7 @@
   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;
 }
@@ -145,6 +172,7 @@
 */
        ())
 {
+  /* This function does not GC */
   struct itimerval foo;
 
   foo.it_value.tv_sec = 0;
@@ -156,6 +184,13 @@
   return Qnil;
 }
 
+static Lisp_Object
+profile_lock_unwind (Lisp_Object ignore)
+{
+  inside_profiling = 0;	
+  return Qnil;
+}
+
 struct get_profiling_info_closure
 {
   Lisp_Object accum;
@@ -166,7 +201,7 @@
 			    void *void_val,
 			    void *void_closure)
 {
-  /* This function can GC */
+  /* This function does not GC */
   Lisp_Object key;
   struct get_profiling_info_closure *closure = void_closure;
   EMACS_INT val;
@@ -183,11 +218,18 @@
 */
        ())
 {
+  /* This function does not GC */
   struct get_profiling_info_closure closure;
 
   closure.accum = Qnil;
   if (big_profile_table)
-    maphash (get_profiling_info_maphash, big_profile_table, &closure);
+    {
+      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;
 }
 
@@ -201,7 +243,6 @@
 			     void *void_val,
 			     void *void_closure)
 {
-  /* This function can GC */
   Lisp_Object key;
   struct mark_profiling_info_closure *closure = void_closure;
 
@@ -212,11 +253,16 @@
 void
 mark_profiling_info (void (*markfun) (Lisp_Object))
 {
+  /* This function does not GC (if markfun doesn't) */
   struct mark_profiling_info_closure closure;
 
   closure.markfun = markfun;
   if (big_profile_table)
-    maphash (mark_profiling_info_maphash, big_profile_table, &closure);
+    {
+      inside_profiling = 1;
+      maphash (mark_profiling_info_maphash, big_profile_table, &closure);
+      inside_profiling = 0;
+    }
 }
 
 DEFUN ("clear-profiling-info", Fclear_profiling_info, 0, 0, 0, /*
@@ -224,8 +270,13 @@
 */
        ())
 {
+  /* This function does not GC */
   if (big_profile_table)
-    clrhash (big_profile_table);
+    {
+      inside_profiling = 1;
+      clrhash (big_profile_table);
+      inside_profiling = 0;
+    }
   return Qnil;
 }
 
@@ -258,6 +309,8 @@
 */ );
   default_profiling_interval = 1000;
 
+  inside_profiling = 0;
+
   QSin_redisplay = build_string ("(in redisplay)");
   staticpro (&QSin_redisplay);
   QSin_garbage_collection = build_string ("(in garbage collection)");