From: simonmar Date: Mon, 22 May 2000 13:09:29 +0000 (+0000) Subject: [project @ 2000-05-22 13:09:29 by simonmar] X-Git-Tag: Approximately_9120_patches~4416 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d3058014b75ef30cc1535dcc6abcf073b3170697;p=ghc-hetmet.git [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. --- diff --git a/ghc/lib/std/PrelWeak.lhs b/ghc/lib/std/PrelWeak.lhs index 97a7bf5..d7cfaac 100644 --- a/ghc/lib/std/PrelWeak.lhs +++ b/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} diff --git a/ghc/rts/Prelude.c b/ghc/rts/Prelude.c index 21ebc57..7188e74 100644 --- a/ghc/rts/Prelude.c +++ b/ghc/rts/Prelude.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $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 diff --git a/ghc/rts/Prelude.h b/ghc/rts/Prelude.h index ccbbe3b..9a64fb2 100644 --- a/ghc/rts/Prelude.h +++ b/ghc/rts/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 diff --git a/ghc/rts/Weak.c b/ghc/rts/Weak.c index ea52d90..117d6a0 100644 --- a/ghc/rts/Weak.c +++ b/ghc/rts/Weak.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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); }