[project @ 2000-05-22 13:09:29 by simonmar]

Batch finalizers on a per-GC basis.  That is, after a GC a single
thread is created to run the pending finalizers, rather than creating
a thread for each finalizer.

This is almost as fast as having a global thread to run finalizers,
but doesn't require any global state or special treatment by the
scheduler.

ghc/lib/std/PrelWeak.lhs

@@ -13,7 +13,7 @@ import PrelGHC
 import PrelBase
 import PrelMaybe
 -- NOTE: To break a cycle, ForeignObj is not in PrelForeign, but PrelIOBase!
-import PrelIOBase	( IO(..), ForeignObj(..) )
+import PrelIOBase	( IO(..), unIO, ForeignObj(..) )
 
 #ifndef __PARALLEL_HASKELL__
 
@@ -41,10 +41,31 @@ addForeignFinalizer :: ForeignObj -> IO () -> IO ()
 addForeignFinalizer (ForeignObj fo) finalizer = addFinalizer fo finalizer
 
 {-
-instance Eq (Weak v) where
+Instance Eq (Weak v) where
   (Weak w1) == (Weak w2) = w1 `sameWeak#` w2
 -}
 
+
+-- run a batch of finalizers from the garbage collector.  We're given 
+-- an array of finalizers and the length of the array, and we just
+-- call each one in turn.
+--
+-- the IO primitives are inlined by hand here to get the optimal
+-- code (sigh) --SDM.
+
+runFinalizerBatch :: Int -> Array# (IO ()) -> IO ()
+runFinalizerBatch (I# n) arr = 
+   let  go m  = IO $ \s ->
+		  case m of 
+		  0# -> (# s, () #)
+		  _  -> let m' = m -# 1# in
+			case indexArray# arr m' of { (# io #) -> 
+			case unIO io s of	   { (# s, _ #) -> 
+			unIO (go m') s
+			}}
+   in
+        go n
+
 #endif
 
 \end{code}

ghc/rts/Prelude.c

 
 /* -----------------------------------------------------------------------------
- * $Id: Prelude.c,v 1.6 2000/04/14 16:47:43 panne Exp $
+ * $Id: Prelude.c,v 1.7 2000/05/22 13:09:29 simonmar Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -15,12 +15,13 @@
 const StgClosure *ind_True_closure;
 const StgClosure *ind_False_closure;
 const StgClosure *ind_unpackCString_closure;
+const StgClosure *ind_runFinalizerBatch_closure;
+
 const StgClosure *ind_stackOverflow_closure;
 const StgClosure *ind_heapOverflow_closure;
 const StgClosure *ind_PutFullMVar_closure;
 const StgClosure *ind_BlockedOnDeadMVar_closure;
 const StgClosure *ind_NonTermination_closure;
-const StgClosure *ind_mainIO_closure;
 
 const StgInfoTable *ind_Czh_static_info;
 const StgInfoTable *ind_Izh_static_info;
@@ -102,6 +103,7 @@ void fixupRTStoPreludeRefs ( void*(*ask_hugs_dynamic_linker)(char*) )
     /* Hugs standalone mode. */
     ind_True_closure               = NULL; /* True__closure; */
     ind_False_closure              = NULL; /* False_closure; */
+    ind_runFinalizerBatch_closure  = NULL; /* runFinalizerBatch_closure; */
     ind_PutFullMVar_closure        = NULL; /* PutFullMVar_closure; */
     ind_BlockedOnDeadMVar_closure  = NULL; /* BlockedOnDeadMVar_closure; */
     ind_NonTermination_closure     = NULL; /* NonTermination_closure; */
@@ -136,6 +138,8 @@ void fixupRTStoPreludeRefs ( void*(*ask_hugs_dynamic_linker)(char*) )
        = ask("PrelBase_True_closure");
     ind_False_closure          
        = ask("PrelBase_False_closure");
+    ind_runFinalizerBatch_closure    
+       = ask("PrelWeak_runFinalizzerBatch_closure");
     ind_PutFullMVar_closure    
        = ask("PrelException_PutFullMVar_closure");
     ind_BlockedOnDeadMVar_closure    

ghc/rts/Prelude.h

 /* -----------------------------------------------------------------------------
- * $Id: Prelude.h,v 1.8 2000/03/30 10:36:15 simonmar Exp $
+ * $Id: Prelude.h,v 1.9 2000/05/22 13:09:29 simonmar Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -18,10 +18,11 @@
 extern DLL_IMPORT const StgClosure PrelBase_True_closure;
 extern DLL_IMPORT const StgClosure PrelBase_False_closure;
 extern DLL_IMPORT const StgClosure PrelPack_unpackCString_closure;
-extern DLL_IMPORT const StgClosure PrelException_stackOverflow_closure;
-extern DLL_IMPORT const StgClosure PrelException_heapOverflow_closure;
+extern DLL_IMPORT const StgClosure PrelWeak_runFinalizzerBatch_closure;
 extern const StgClosure PrelMain_mainIO_closure;
 
+extern DLL_IMPORT const StgClosure PrelException_stackOverflow_closure;
+extern DLL_IMPORT const StgClosure PrelException_heapOverflow_closure;
 extern DLL_IMPORT const StgClosure PrelException_PutFullMVar_closure;
 extern DLL_IMPORT const StgClosure PrelException_BlockedOnDeadMVar_closure;
 extern DLL_IMPORT const StgClosure PrelException_NonTermination_closure;
@@ -43,31 +44,34 @@ extern DLL_IMPORT const StgInfoTable PrelAddr_W64zh_con_info;
 extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_static_info;
 extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info;
 
-#define True_closure           (&PrelBase_True_closure)
-#define False_closure          (&PrelBase_False_closure)
-#define stackOverflow_closure  (&PrelException_stackOverflow_closure)
-#define heapOverflow_closure   (&PrelException_heapOverflow_closure)
-#define PutFullMVar_closure    (&PrelException_PutFullMVar_closure)
+#define True_closure              (&PrelBase_True_closure)
+#define False_closure             (&PrelBase_False_closure)
+#define unpackCString_closure     (&PrelPack_unpackCString_closure)
+#define runFinalizerBatch_closure (&PrelWeak_runFinalizzerBatch_closure)
+#define mainIO_closure            (&PrelMain_mainIO_closure)
+
+#define stackOverflow_closure     (&PrelException_stackOverflow_closure)
+#define heapOverflow_closure      (&PrelException_heapOverflow_closure)
+#define PutFullMVar_closure       (&PrelException_PutFullMVar_closure)
 #define BlockedOnDeadMVar_closure (&PrelException_BlockedOnDeadMVar_closure)
-#define NonTermination_closure (&PrelException_NonTermination_closure)
-#define Czh_static_info        (&PrelBase_Czh_static_info)
-#define Izh_static_info        (&PrelBase_Izh_static_info)
-#define Fzh_static_info        (&PrelFloat_Fzh_static_info)
-#define Dzh_static_info        (&PrelFloat_Dzh_static_info)
-#define Azh_static_info        (&PrelAddr_Azh_static_info)
-#define Wzh_static_info        (&PrelAddr_Wzh_static_info)
-#define Czh_con_info           (&PrelBase_Czh_con_info)
-#define Izh_con_info           (&PrelBase_Izh_con_info)
-#define Fzh_con_info           (&PrelFloat_Fzh_con_info)
-#define Dzh_con_info           (&PrelFloat_Dzh_con_info)
-#define Azh_con_info           (&PrelAddr_Azh_con_info)
-#define Wzh_con_info           (&PrelAddr_Wzh_con_info)
-#define W64zh_con_info         (&PrelAddr_W64zh_con_info)
-#define I64zh_con_info         (&PrelAddr_I64zh_con_info)
-#define StablePtr_static_info  (&PrelStable_StablePtr_static_info)
-#define StablePtr_con_info     (&PrelStable_StablePtr_con_info)
-#define mainIO_closure         (&PrelMain_mainIO_closure)
-#define unpackCString_closure  (&PrelPack_unpackCString_closure)
+#define NonTermination_closure    (&PrelException_NonTermination_closure)
+
+#define Czh_static_info           (&PrelBase_Czh_static_info)
+#define Izh_static_info           (&PrelBase_Izh_static_info)
+#define Fzh_static_info           (&PrelFloat_Fzh_static_info)
+#define Dzh_static_info           (&PrelFloat_Dzh_static_info)
+#define Azh_static_info           (&PrelAddr_Azh_static_info)
+#define Wzh_static_info           (&PrelAddr_Wzh_static_info)
+#define Czh_con_info              (&PrelBase_Czh_con_info)
+#define Izh_con_info              (&PrelBase_Izh_con_info)
+#define Fzh_con_info              (&PrelFloat_Fzh_con_info)
+#define Dzh_con_info              (&PrelFloat_Dzh_con_info)
+#define Azh_con_info              (&PrelAddr_Azh_con_info)
+#define Wzh_con_info              (&PrelAddr_Wzh_con_info)
+#define W64zh_con_info            (&PrelAddr_W64zh_con_info)
+#define I64zh_con_info            (&PrelAddr_I64zh_con_info)
+#define StablePtr_static_info     (&PrelStable_StablePtr_static_info)
+#define StablePtr_con_info        (&PrelStable_StablePtr_con_info)
 
 #else /* INTERPRETER */
 
@@ -77,6 +81,8 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info;
 extern const StgClosure *ind_True_closure;
 extern const StgClosure *ind_False_closure;
 extern const StgClosure *ind_unpackCString_closure;
+extern const StgClosure *ind_runFinalizerBatch_closure;
+
 extern const StgClosure *ind_stackOverflow_closure;
 extern const StgClosure *ind_heapOverflow_closure;
 extern const StgClosure *ind_PutFullMVar_closure;
@@ -102,11 +108,15 @@ extern const StgInfoTable *ind_StablePtr_con_info;
 
 #define True_closure           ind_True_closure
 #define False_closure          ind_False_closure
+#define unpackCString_closure  ind_unpackCString_closure
+#define runFinalizerBatch_closure ind_runFinalizerBatch_closure;
+
 #define stackOverflow_closure  ind_stackOverflow_closure
 #define heapOverflow_closure   ind_heapOverflow_closure
 #define PutFullMVar_closure    ind_PutFullMVar_closure
 #define BlockedOnDeadMVar_closure ind_BlockedOnDeadMVar_closure
 #define NonTermination_closure ind_NonTermination_closure
+
 #define Czh_static_info        ind_Czh_static_info
 #define Izh_static_info        ind_Izh_static_info
 #define Fzh_static_info        ind_Fzh_static_info
@@ -123,7 +133,6 @@ extern const StgInfoTable *ind_StablePtr_con_info;
 #define I64zh_con_info         ind_I64zh_con_info
 #define StablePtr_static_info  ind_StablePtr_static_info
 #define StablePtr_con_info     ind_StablePtr_con_info
-#define unpackCString_closure  ind_unpackCString_closure
 
 #endif
 

ghc/rts/Weak.c

 /* -----------------------------------------------------------------------------
- * $Id: Weak.c,v 1.13 2000/02/25 17:35:11 sewardj Exp $
+ * $Id: Weak.c,v 1.14 2000/05/22 13:09:29 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -13,6 +13,7 @@
 #include "RtsFlags.h"
 #include "Weak.h"
 #include "Storage.h"
+#include "Prelude.h"
 
 StgWeak *weak_ptr_list;
 
@@ -44,7 +45,7 @@ finalizeWeakPointersNow(void)
 /*
  * scheduleFinalizers() is called on the list of weak pointers found
  * to be dead after a garbage collection.  It overwrites each object
- * with DEAD_WEAK, and creates a new thread for the finalizer.
+ * with DEAD_WEAK, and creates a new thread to run the pending finalizers.
  *
  * This function is called just after GC.  The weak pointers on the
  * argument list are those whose keys were found to be not reachable,
@@ -57,15 +58,39 @@ finalizeWeakPointersNow(void)
 void
 scheduleFinalizers(StgWeak *list)
 {
-  StgWeak *w;
-  StgTSO *t;
-  
-  for (w = list; w; w = w->link) {
-    IF_DEBUG(weak,fprintf(stderr,"Finalising weak pointer at %p -> %p\n", w, w->key));
-    if (w->finalizer != &NO_FINALIZER_closure) {
-      t = createIOThread(RtsFlags.GcFlags.initialStkSize, w->finalizer);
-      scheduleThread(t);
+    StgWeak *w;
+    StgTSO *t;
+    StgMutArrPtrs *arr;
+    nat n;
+
+    /* count number of finalizers first... */
+    for (n = 0, w = list; w; w = w->link) { 
+	if (w->finalizer != &NO_FINALIZER_closure)
+	    n++;
     }
-    w->header.info = &DEAD_WEAK_info;
-  }
+	
+    if (n == 0) return;
+
+    IF_DEBUG(weak,fprintf(stderr,"weak: batching %d finalizers\n", n));
+
+    arr = (StgMutArrPtrs *)allocate(sizeofW(StgMutArrPtrs) + n);
+    SET_HDR(arr, &MUT_ARR_PTRS_FROZEN_info, CCS_SYSTEM);
+    arr->ptrs = n;
+
+    for (n = 0, w = list; w; w = w->link) {
+	if (w->finalizer != &NO_FINALIZER_closure) {
+	    arr->payload[n] = w->finalizer;
+	    n++;
+	}
+	w->header.info = &DEAD_WEAK_info;
+    }
+
+    t = createIOThread(RtsFlags.GcFlags.initialStkSize, 
+		       rts_apply(
+			   rts_apply(
+			       (StgClosure *)runFinalizerBatch_closure,
+			       rts_mkInt(n)), 
+			   (StgClosure *)arr)
+	);
+    scheduleThread(t);
 }