diff options
| -rw-r--r-- | compiler/cmm/Cmm.hs | 7 | ||||
| -rw-r--r-- | compiler/cmm/CmmBuildInfoTables.hs | 224 | ||||
| -rw-r--r-- | compiler/cmm/CmmInfo.hs | 3 | ||||
| -rw-r--r-- | compiler/cmm/CmmParse.y | 12 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 22 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 19 | ||||
| -rw-r--r-- | includes/rts/storage/ClosureMacros.h | 3 | ||||
| -rw-r--r-- | rts/RetainerProfile.c | 2 | ||||
| -rw-r--r-- | rts/sm/Compact.c | 2 | ||||
| -rw-r--r-- | rts/sm/Evac.c | 4 | ||||
| -rw-r--r-- | rts/sm/Sanity.c | 2 | ||||
| -rw-r--r-- | rts/sm/Scav.c | 4 |
12 files changed, 182 insertions, 122 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index f059a7b3a8..4c8e528250 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -27,6 +27,8 @@ module Cmm ( import GhcPrelude +import Id +import CostCentre import CLabel import BlockId import CmmNode @@ -137,7 +139,10 @@ data CmmInfoTable cit_lbl :: CLabel, -- Info table label cit_rep :: SMRep, cit_prof :: ProfilingInfo, - cit_srt :: Maybe CLabel -- empty, or a closure address + cit_srt :: Maybe CLabel, -- empty, or a closure address + cit_clo :: Maybe (Id, CostCentreStack) + -- Just (id,ccs) <=> build a static closure later + -- Nothing <=> don't build a static closure } data ProfilingInfo diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 043f62f811..d9408df202 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, BangPatterns, RecordWildCards, - GeneralizedNewtypeDeriving, NondecreasingIndentation #-} + GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-} module CmmBuildInfoTables ( CAFSet, CAFEnv, cafAnal @@ -8,6 +8,7 @@ module CmmBuildInfoTables import GhcPrelude hiding (succ) +import Id import BlockId import Hoopl.Block import Hoopl.Graph @@ -34,7 +35,6 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Tuple -import Control.Monad import Control.Monad.Trans.State import Control.Monad.Trans.Class @@ -228,63 +228,47 @@ implemented. optimisation and generate the singleton SRT, becase SRTs are in the data section and *can* have relocatable references. -2. [FUN] If an SRT refers to a top-level function (a FUN_STATIC), then - we can shortcut the reference to point directly to the function's - SRT instead. +2. [FUN] A static function closure can also be an SRT, we simply put + the SRT entries as fields in the static closure. This makes a lot + of sense: the static references are just like the free variables of + the FUN closure. i.e. instead of - +---+---+--- - |SRT| | | - +---+-|-+--- - | - v - +---+---+ - | | | 0 | - +-|-+---+ - | - | +------+ - | | info | - | | | +-----+---+---+ - | | -------->|SRT_1| | | 0 | - `----->|------| +-----+-|-+---+ - | | | - | code | | - | | v - closure - - we can generate - - +---+---+--- - |SRT| | | - +---+-|-+--- - `----------------------, - | - +---+---+ | - | | | 0 | | - +-|-+---+ | - | | - | +------+ | - | | info | v - | | | +-----+---+---+ - | | -------->|SRT_1| | | 0 | - `----->|------| +-----+-|-+---+ - | | | - | code | | - | | v - closure - - This is quicker for the garbage collector to traverse, and avoids - setting the static link field on the function's closure. - - Of course we can only do this if we know what the function's SRT - is. Due to [Shortcut] the function's SRT can be an arbitrary - closure, so this optimisation only applies within a module. - - Note: we can *not* do this optimisation for top-level thunks - (CAFs), because we want the SRT to point directly to the - CAF. Otherwise the SRT would keep the CAF's static references alive - even after the CAF had been evaluated! + f_closure: + +-----+---+ + | | | 0 | + +- |--+---+ + | +------+ + | | info | f_srt: + | | | +-----+---+---+---+ + | | -------->|SRT_2| | | | + 0 | + `----------->|------| +-----+-|-+-|-+---+ + | | | | + | code | | | + | | v v + + + We can generate: + + f_closure: + +-----+---+---+---+ + | | | | | | | 0 | + +- |--+-|-+-|-+---+ + | | | +------+ + | v v | info | + | | | + | | 0 | + `----------->|------| + | | + | code | + | | + + + (note: we can't do this for THUNKs, because the thunk gets + overwritten when it is entered, so we wouldn't be able to share + this SRT with other info tables that want to refer to it (see + [Common] below). FUNs are immutable so don't have this problem.) 3. [Common] Identical SRTs can be commoned up. @@ -293,9 +277,6 @@ implemented. to C from A. -As an alternative to [FUN]: we could merge the FUN's SRT with the FUN -object itself. - Note that there are many other optimisations that we could do, but aren't implemented. In general, we could omit any reference from an SRT if everything reachable from it is also reachable from the other @@ -479,6 +460,19 @@ getCAFs (CmmProc top_info topLbl _ g) , isStaticRep rep && isThunkRep rep = [(g_entry g, mkCAFLabel topLbl)] | otherwise = [] +-- | Get the list of blocks that correspond to the entry points for +-- FUN_STATIC closures. These are the blocks for which if we have an +-- SRT we can merge it with the static closure. [FUN] +getStaticFuns :: CmmDecl -> [(BlockId, CLabel)] +getStaticFuns (CmmData _ _) = [] +getStaticFuns (CmmProc top_info _ _ g) + | Just info <- mapLookup (g_entry g) (info_tbls top_info) + , let rep = cit_rep info + , Just (id, _) <- cit_clo info + , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id) + , isStaticRep rep && isFunRep rep = [(g_entry g, lbl)] + | otherwise = [] + -- | Put the labelled blocks that we will be annotating with SRTs into -- dependency order. This is so that we can process them one at a @@ -541,6 +535,7 @@ doSRTs dflags topSRT tops = do let (cafEnvs, declss) = unzip tops cafEnv = mapUnions cafEnvs decls = concat declss + staticFuns = mapFromList (concatMap getStaticFuns decls) -- Put the decls in dependency order. Why? So that we can implement -- [Shortcut] and [Filter]. If we need to refer to an SRT that has @@ -552,14 +547,19 @@ doSRTs dflags topSRT tops = do -- On each strongly-connected group of decls, construct the SRT -- closures and the SRT fields for info tables. - let (((declss, pairs), _srtMap), topSRT') = + let ((result, _srtMap), topSRT') = initUs_ us $ flip runStateT topSRT $ flip runStateT Map.empty $ - mapAndUnzipM (doSCC dflags) sccs + mapM (doSCC dflags staticFuns) sccs + + (declss, pairs, funSRTs) = unzip3 result -- Next, update the info tables with the SRTs - let decls' = map (updInfoSRTs (mapFromList (concat pairs))) decls + let + srtFieldMap = mapFromList (concat pairs) + funSRTMap = mapFromList (concat funSRTs) + decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls return (topSRT', concat declss ++ decls') @@ -567,26 +567,29 @@ doSRTs dflags topSRT tops = do -- | Build the SRT for a strongly-connected component of blocks doSCC :: DynFlags + -> LabelMap CLabel -- which blocks are static function entry points -> SCC (Label, CAFLabel, Set CAFLabel) -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) - ( [CmmDecl] -- generated SRTs - , [(Label, CLabel)] -- SRT fields for info tables + ( [CmmDecl] -- generated SRTs + , [(Label, CLabel)] -- SRT fields for info tables + , [(Label, [SRTEntry])] -- SRTs to attach to static functions ) -doSCC dflags (AcyclicSCC (l, cafLbl, cafs)) = - oneSRT dflags [l] [cafLbl] cafs +doSCC dflags staticFuns (AcyclicSCC (l, cafLbl, cafs)) = + oneSRT dflags staticFuns [l] [cafLbl] cafs -doSCC dflags (CyclicSCC nodes) = do +doSCC dflags staticFuns (CyclicSCC nodes) = do -- build a single SRT for the whole cycle let (blockids, lbls, cafsets) = unzip3 nodes cafs = Set.unions cafsets `Set.difference` Set.fromList lbls - oneSRT dflags blockids lbls cafs + oneSRT dflags staticFuns blockids lbls cafs -- | Build an SRT for a set of blocks oneSRT :: DynFlags + -> LabelMap CLabel -- which blocks are static function entry points -> [Label] -- blocks in this set -> [CAFLabel] -- labels for those blocks -> Set CAFLabel -- SRT for this set @@ -594,9 +597,10 @@ oneSRT (StateT ModuleSRTInfo UniqSM) ( [CmmDecl] -- SRT objects we built , [(Label, CLabel)] -- SRT fields for these blocks' itbls + , [(Label, [SRTEntry])] -- SRTs to attach to static functions ) -oneSRT dflags blockids lbls cafs = do +oneSRT dflags staticFuns blockids lbls cafs = do srtMap <- get topSRT <- lift get let @@ -627,12 +631,12 @@ oneSRT dflags blockids lbls cafs = do [] -> do srtTrace "oneSRT: empty" (ppr lbls) $ return () updateSRTMap Nothing - return ([], []) + return ([], [], []) [one@(SRTEntry lbl)] | not (labelDynamic dflags (thisModule topSRT) lbl) -> do updateSRTMap (Just one) - return ([], [(l, lbl) | l <- blockids]) + return ([], map (,lbl) blockids, []) cafList -> -- Check whether an SRT with the same entries has been emitted already. @@ -641,11 +645,21 @@ oneSRT dflags blockids lbls cafs = do Just srtEntry@(SRTEntry srtLbl) -> do srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return () updateSRTMap (Just srtEntry) - return ([], [(l, srtLbl) | l <- blockids]) + return ([], map (,srtLbl) blockids, []) Nothing -> do -- No duplicates: we have to build a new SRT object srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return () - (decls, srtEntry) <- lift . lift $ buildSRTChain dflags cafList + let + -- Can we merge this SRT with a FUN_STATIC closure? + maybeFunClosure = listToMaybe + [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] + (decls, funSRTs, srtEntry) <- + case maybeFunClosure of + Just (fun,block) -> + return ( [], [(block, cafList)], SRTEntry fun ) + Nothing -> do + (decls, entry) <- lift . lift $ buildSRTChain dflags cafList + return (decls, [], entry) updateSRTMap (Just srtEntry) let allBelowThis = Set.union allBelow filtered oldFlatSRTs = flatSRTs topSRT @@ -654,7 +668,7 @@ oneSRT dflags blockids lbls cafs = do lift (put (topSRT { dedupSRTs = newDedupSRTs , flatSRTs = newFlatSRTs })) let SRTEntry lbl = srtEntry - return (decls, [(l, lbl) | l <- blockids]) + return (decls, map (,lbl) blockids, funSRTs) -- | build a static SRT object (or a chain of objects) from a list of @@ -695,21 +709,57 @@ buildSRT dflags refs = do return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl) -{- Note [reverse gs] - - It is important to keep the code blocks in the same order, - otherwise binary sizes get slightly bigger. I'm not completely - sure why this is, perhaps the assembler generates bigger jump - instructions for forward refs. --SDM --} +-- | Update info tables with references to their SRTs. Also generate +-- static closures, splicing in SRT fields as necessary. +updInfoSRTs + :: DynFlags + -> LabelMap CLabel -- SRT labels for each block + -> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures + -> CmmDecl + -> [CmmDecl] -updInfoSRTs :: LabelMap CLabel -> CmmDecl -> CmmDecl -updInfoSRTs srt_env (CmmProc top_info top_l live g) = - CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g - where updInfoTbl l info_tbl - = info_tbl { cit_srt = mapLookup l srt_env } -updInfoSRTs _ t = t +updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g) + | Just (_,closure) <- maybeStaticClosure = [ proc, closure ] + | otherwise = [ proc ] + where + proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g + newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info) + updInfoTbl l info_tbl + | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf + | otherwise = info_tbl { cit_srt = mapLookup l srt_env } + + -- Generate static closures [FUN]. Note that this also generates + -- static closures for thunks (CAFs), because it's easier to treat + -- them uniformly in the code generator. + maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl) + maybeStaticClosure + | Just info_tbl@CmmInfoTable{..} <- + mapLookup (g_entry g) (info_tbls top_info) + , Just (id, ccs) <- cit_clo + , isStaticRep cit_rep = + let + (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of + Nothing -> + -- if we don't add SRT entries to this closure, then we + -- want to set the srt field in its info table as usual + (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, []) + Just srtEntries -> srtTrace "maybeStaticFun" (ppr res) + (info_tbl { cit_rep = new_rep }, res) + where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ] + fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id) + srtEntries + new_rep = case cit_rep of + HeapRep sta ptrs nptrs ty -> + HeapRep sta (ptrs + length srtEntries) nptrs ty + _other -> panic "maybeStaticFun" + lbl = mkLocalClosureLabel (idName id) (idCafInfo id) + in + Just (newInfo, mkDataLits (Section Data lbl) lbl fields) + | otherwise = Nothing + +updInfoSRTs _ _ _ t = [t] srtTrace :: String -> SDoc -> b -> b +-- srtTrace = pprTrace srtTrace _ _ b = b diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 4201fda36a..3b2eea1a5e 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -63,7 +63,8 @@ mkEmptyContInfoTable info_lbl = CmmInfoTable { cit_lbl = info_lbl , cit_rep = mkStackRep [] , cit_prof = NoProfilingInfo - , cit_srt = Nothing } + , cit_srt = Nothing + , cit_clo = Nothing } cmmToRawCmm :: DynFlags -> Stream IO CmmGroup () -> IO (Stream IO RawCmmGroup ()) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 1bdf0e6a7e..2113f20a0f 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -472,7 +472,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } return (mkCmmEntryLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing }, + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, []) } | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' @@ -488,7 +488,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } return (mkCmmEntryLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing }, + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, []) } -- we leave most of the fields zero here. This is only used -- to generate the BCO info table in the RTS at the moment. @@ -506,7 +506,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } return (mkCmmEntryLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing }, + , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing }, []) } -- If profiling is on, this string gets duplicated, @@ -523,7 +523,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } return (mkCmmEntryLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing }, + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, []) } | 'INFO_TABLE_RET' '(' NAME ',' INT ')' @@ -534,7 +534,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } return (mkCmmRetLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing }, + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, []) } | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' @@ -549,7 +549,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } return (mkCmmRetLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing }, + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, live) } body :: { CmmParse () } diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index b29394da6f..aa2b954a95 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -95,19 +95,17 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body = emitDataLits closure_label closure_rep return () - gen_code dflags lf_info closure_label - = do { -- LAY OUT THE OBJECT - let name = idName id + gen_code dflags lf_info _closure_label + = do { let name = idName id ; mod_name <- getModuleName ; let descr = closureDescription dflags mod_name name closure_info = mkClosureInfo dflags True id lf_info 0 0 descr - caffy = idCafInfo id - info_tbl = mkCmmInfo closure_info -- XXX short-cut - closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] + -- We don't generate the static closure here, because we might + -- want to add references to static closures to it later. The + -- static closure is generated by CmmBuildInfoTables.updInfoSRTs, + -- See Note [SRTs], specifically the [FUN] optimisation. - -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) - ; emitDataLits closure_label closure_rep ; let fv_details :: [(NonVoid Id, ByteOff)] header = if isLFThunk lf_info then ThunkHeader else StdHeader (_, _, fv_details) = mkVirtHeapOffsets dflags header [] @@ -367,7 +365,7 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body ; let use_cc = cccsExpr; blame_cc = cccsExpr ; emit (mkComment $ mkFastString "calling allocDynClosure") ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) - ; let info_tbl = mkCmmInfo closure_info + ; let info_tbl = mkCmmInfo closure_info bndr currentCCS ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc (map toVarArg fv_details) @@ -407,7 +405,7 @@ cgRhsStdThunk bndr lf_info payload -- BUILD THE OBJECT - ; let info_tbl = mkCmmInfo closure_info + ; let info_tbl = mkCmmInfo closure_info bndr currentCCS ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc payload_w_offsets @@ -463,7 +461,7 @@ closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details \(_, node, _) -> thunkCode cl_info fv_details cc node arity body where lf_info = closureLFInfo cl_info - info_tbl = mkCmmInfo cl_info + info_tbl = mkCmmInfo cl_info bndr cc closureCodeBody top_lvl bndr cl_info cc args arity body fv_details = -- Note: args may be [], if all args are Void @@ -474,7 +472,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details ; let lf_info = closureLFInfo cl_info - info_tbl = mkCmmInfo cl_info + info_tbl = mkCmmInfo cl_info bndr cc -- Emit the main entry code ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $ diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index d58e9f6f88..e0306eeba3 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -73,6 +73,7 @@ import SMRep import Cmm import PprCmmExpr() +import CostCentre import BlockId import CLabel import Id @@ -750,12 +751,15 @@ data ClosureInfo } -- | Convert from 'ClosureInfo' to 'CmmInfoTable'. -mkCmmInfo :: ClosureInfo -> CmmInfoTable -mkCmmInfo ClosureInfo {..} +mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable +mkCmmInfo ClosureInfo {..} id ccs = CmmInfoTable { cit_lbl = closureInfoLabel , cit_rep = closureSMRep , cit_prof = closureProf - , cit_srt = Nothing } + , cit_srt = Nothing + , cit_clo = if isStaticRep closureSMRep + then Just (id,ccs) + else Nothing } -------------------------------------- -- Building ClosureInfos @@ -1040,7 +1044,8 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds = CmmInfoTable { cit_lbl = info_lbl , cit_rep = sm_rep , cit_prof = prof - , cit_srt = Nothing } + , cit_srt = Nothing + , cit_clo = Nothing } where name = dataConName data_con info_lbl = mkConInfoTableLabel name NoCafRefs @@ -1063,14 +1068,16 @@ cafBlackHoleInfoTable = CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel , cit_rep = blackHoleRep , cit_prof = NoProfilingInfo - , cit_srt = Nothing } + , cit_srt = Nothing + , cit_clo = Nothing } indStaticInfoTable :: CmmInfoTable indStaticInfoTable = CmmInfoTable { cit_lbl = mkIndStaticInfoLabel , cit_rep = indStaticRep , cit_prof = NoProfilingInfo - , cit_srt = Nothing } + , cit_srt = Nothing + , cit_clo = Nothing } staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool -- A static closure needs a link field to aid the GC when traversing diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h index 7a3ecaa1d2..dcbc95b31b 100644 --- a/includes/rts/storage/ClosureMacros.h +++ b/includes/rts/storage/ClosureMacros.h @@ -172,7 +172,6 @@ INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con) -------------------------------------------------------------------------- */ /* These are hard-coded. */ -#define FUN_STATIC_LINK(p) (&(p)->payload[0]) #define THUNK_STATIC_LINK(p) (&(p)->payload[1]) #define IND_STATIC_LINK(p) (&(p)->payload[1]) @@ -182,8 +181,6 @@ STATIC_LINK(const StgInfoTable *info, StgClosure *p) switch (info->type) { case THUNK_STATIC: return THUNK_STATIC_LINK(p); - case FUN_STATIC: - return FUN_STATIC_LINK(p); case IND_STATIC: return IND_STATIC_LINK(p); default: diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index 67a6da93cd..5a4530a8aa 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -1908,7 +1908,7 @@ resetStaticObjectForRetainerProfiling( StgClosure *static_objects ) break; case FUN_STATIC: maybeInitRetainerSet(p); - p = (StgClosure*)*FUN_STATIC_LINK(p); + p = (StgClosure*)*STATIC_LINK(p); break; case CONSTR: case CONSTR_1_0: diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index 0e2fea8990..f252e89161 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -212,7 +212,7 @@ thread_static( StgClosure* p ) p = *THUNK_STATIC_LINK(p); continue; case FUN_STATIC: - p = *FUN_STATIC_LINK(p); + p = *STATIC_LINK(info,p); continue; case CONSTR: case CONSTR_NOCAF: diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index a8559e7e00..e8baebe553 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -542,8 +542,8 @@ loop: return; case FUN_STATIC: - if (info->srt != 0) { - evacuate_static_object(FUN_STATIC_LINK((StgClosure *)q), q); + if (info->srt != 0 || info->layout.payload.ptrs != 0) { + evacuate_static_object(STATIC_LINK(info,(StgClosure *)q), q); } return; diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index 7a0ad1672f..defefa3f01 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -677,7 +677,7 @@ checkStaticObjects ( StgClosure* static_objects ) break; case FUN_STATIC: - p = *FUN_STATIC_LINK((StgClosure *)p); + p = *STATIC_LINK(info,(StgClosure *)p); break; case CONSTR: diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index 79adcaa826..5db0acbbee 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -1722,7 +1722,9 @@ scavenge_static(void) case FUN_STATIC: scavenge_fun_srt(info); - break; + // fallthrough: a FUN_STATIC can also be an SRT, so it may have pointer + // fields. See Note [SRTs] in CmmBuildInfoTables, specifically the [FUN] + // optimisation. case CONSTR: case CONSTR_NOCAF: |