changeset 887:ccc3177ef10b

[xemacs-hg @ 2002-06-28 14:21:41 by michaels] 2002-06-27 Mike Sperber <mike@xemacs.org> * eval.c (Ffuncall): Run `post-gc-hook' if GC just happened. * alloc.c (garbage_collect_1): Delay running `post-gc-hook' until later.
author michaels
date Fri, 28 Jun 2002 14:21:41 +0000
parents 011e1bce6ece
children 201c016cfc12
files src/alloc.c src/eval.c
diffstat 2 files changed, 41 insertions(+), 8 deletions(-) [+]
line wrap: on
line diff
--- a/src/alloc.c	Fri Jun 28 14:20:42 2002 +0000
+++ b/src/alloc.c	Fri Jun 28 14:21:41 2002 +0000
@@ -96,6 +96,7 @@
 static EMACS_INT consing_since_gc;
 int need_to_garbage_collect;
 int need_to_check_c_alloca;
+int need_to_signal_post_gc;
 int funcall_allocation_flag;
 Bytecount __temp_alloca_size__;
 Bytecount funcall_alloca_count;
@@ -3626,6 +3627,9 @@
      have infinite GC recursion. */
   speccount = begin_gc_forbidden ();
 
+  need_to_signal_post_gc = 0;
+  recompute_funcall_allocation_flag();
+
   if (!gc_hooks_inhibited)
     run_hook_trapping_problems
       ("Error in pre-gc-hook", Qpre_gc_hook,
@@ -3770,7 +3774,8 @@
      iterate until nothing more gets marked. */
 
   while (finish_marking_weak_hash_tables () > 0 ||
-	 finish_marking_weak_lists       () > 0)
+	 finish_marking_weak_lists       () > 0 ||
+	 finish_marking_ephemerons       () > 0)
     ;
 
   /* And prune (this needs to be called after everything else has been
@@ -3782,6 +3787,7 @@
   prune_specifiers ();
   prune_syntax_tables ();
 
+  prune_ephemerons ();
   prune_weak_boxes ();
 
   gc_sweep ();
@@ -3801,10 +3807,6 @@
 
   /******* End of garbage collection ********/
 
-  run_hook_trapping_problems
-    ("Error in post-gc-hook", Qpost_gc_hook,
-     INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION);
-
   /* Now remove the GC cursor/message */
   if (!noninteractive)
     {
@@ -3837,6 +3839,10 @@
     }
 
   UNGCPRO;
+
+  need_to_signal_post_gc = 1;
+  funcall_allocation_flag = 1;
+
   return;
 }
 
@@ -4012,7 +4018,10 @@
 void
 recompute_funcall_allocation_flag (void)
 {
-  funcall_allocation_flag = need_to_garbage_collect || need_to_check_c_alloca;
+  funcall_allocation_flag =
+    need_to_garbage_collect ||
+    need_to_check_c_alloca ||
+    need_to_signal_post_gc;
 }
 
 /* True if it's time to garbage collect now. */
@@ -4427,8 +4436,8 @@
   DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
 Function or functions to be run just after each garbage collection.
 Interrupts, garbage collection, and errors are inhibited while this hook
-runs, so be extremely careful in what you add here.  In particular, avoid
-consing, and do not interact with the user.
+runs.  Each hook is called with one argument which is an alist with
+finalization data.
 */ );
   Vpost_gc_hook = Qnil;
 
--- a/src/eval.c	Fri Jun 28 14:20:42 2002 +0000
+++ b/src/eval.c	Fri Jun 28 14:21:41 2002 +0000
@@ -246,6 +246,7 @@
 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
 Lisp_Object Qdebugger;
 Lisp_Object Qinhibit_quit;
+Lisp_Object Qfinalize_list;
 Lisp_Object Qrun_hooks;
 Lisp_Object Qsetq;
 Lisp_Object Qdisplay_warning;
@@ -3686,6 +3687,14 @@
 	      funcall_alloca_count = 0;
 	    }
 	}
+      if (need_to_signal_post_gc)
+	{
+	  static void run_post_gc_hook(void); /* forward */
+
+	  need_to_signal_post_gc = 0;
+	  recompute_funcall_allocation_flag();
+	  run_post_gc_hook();
+	}
     }
 
   if (++lisp_eval_depth > max_lisp_eval_depth)
@@ -5511,6 +5520,20 @@
 		   RUN_HOOKS_TO_COMPLETION, flags));
 }
 
+static void
+run_post_gc_hook()
+{
+  Lisp_Object args[2];
+
+  args[0] = Qpost_gc_hook;
+  args[1] = Fcons (Fcons (Qfinalize_list, zap_finalize_list()), Qnil);
+  
+  run_hook_with_args_trapping_problems
+    ("Error in post-gc-hook",
+     2, args,
+     RUN_HOOKS_TO_COMPLETION,
+     INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION);
+}
 
 /************************************************************************/
 /*		       The special binding stack			*/
@@ -6224,6 +6247,7 @@
   DEFSYMBOL (Qvalues);
   DEFSYMBOL (Qdisplay_warning);
   DEFSYMBOL (Qrun_hooks);
+  DEFSYMBOL (Qfinalize_list);
   DEFSYMBOL (Qif);
 
   DEFSUBR (For);