diff options
| -rw-r--r-- | compiler/cmm/CLabel.hs | 22 | ||||
| -rw-r--r-- | compiler/cmm/CmmBuildInfoTables.hs | 9 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmm.hs | 1 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmEnv.hs | 8 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 25 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 4 |
6 files changed, 33 insertions, 36 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index ed4b56767a..907f8521e1 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -13,6 +13,7 @@ module CLabel ( mkClosureLabel, mkSRTLabel, + mkModSRTLabel, mkInfoTableLabel, mkEntryLabel, mkSlowEntryLabel, @@ -119,6 +120,8 @@ import DynFlags import Platform import UniqSet +import Data.Maybe (isJust) + -- ----------------------------------------------------------------------------- -- The CLabel type @@ -214,6 +217,9 @@ data CLabel -- | Per-module table of tick locations | HpcTicksLabel Module + -- | Static reference table + | SRTLabel (Maybe Module) !Unique + -- | Label of an StgLargeSRT | LargeSRTLabel {-# UNPACK #-} !Unique @@ -271,7 +277,9 @@ pprDebugCLabel lbl data IdLabelInfo = Closure -- ^ Label for closure - | SRT -- ^ Static reference table + | SRT -- ^ Static reference table (TODO: could be removed + -- with the old code generator, but might be needed + -- when we implement the New SRT Plan) | InfoTable -- ^ Info tables for closures; always read-only | Entry -- ^ Entry point | Slow -- ^ Slow entry point @@ -347,6 +355,9 @@ data DynamicLinkerLabelInfo mkSlowEntryLabel :: Name -> CafInfo -> CLabel mkSlowEntryLabel name c = IdLabel name c Slow +mkModSRTLabel :: Maybe Module -> Unique -> CLabel +mkModSRTLabel mb_mod u = SRTLabel mb_mod u + mkSRTLabel :: Name -> CafInfo -> CLabel mkRednCountsLabel :: Name -> CafInfo -> CLabel mkSRTLabel name c = IdLabel name c SRT @@ -581,7 +592,7 @@ needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother -- don't bother declaring SRT & Bitmap labels, we always make sure -- they are defined before use. -needsCDecl (IdLabel _ _ SRT) = False +needsCDecl (SRTLabel _ _) = False needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _ _) = True @@ -729,6 +740,7 @@ externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (HpcTicksLabel _) = True externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (SRTLabel mb_mod _) = isJust mb_mod externallyVisibleCLabel (LargeSRTLabel _) = False externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" @@ -776,6 +788,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel +labelType (SRTLabel _ _) = CodeLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@ -978,6 +991,11 @@ pprCLbl (CaseLabel u (CaseAlt tag)) pprCLbl (CaseLabel u CaseDefault) = hcat [pprUnique u, ptext (sLit "_dflt")] +pprCLbl (SRTLabel mb_mod u) + = pp_mod <> pprUnique u <> pp_cSEP <> ptext (sLit "srt") + where pp_mod | Just mod <- mb_mod = ppr mod <> pp_cSEP + | otherwise = empty + pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd") pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm") -- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7') diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 309536b963..0cfcc0d5be 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -32,10 +32,9 @@ import Bitmap import CLabel import Cmm import CmmUtils -import IdInfo import Data.List import Maybes -import Name +import Module import Outputable import SMRep import UniqSupply @@ -137,9 +136,9 @@ instance Outputable TopSRT where <+> ppr elts <+> ppr eltmap -emptySRT :: MonadUnique m => m TopSRT -emptySRT = - do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs +emptySRT :: MonadUnique m => Maybe Module -> m TopSRT +emptySRT mb_mod = + do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty } cafMember :: TopSRT -> CLabel -> Bool diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index b8ed1aa939..d74533d76e 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -143,7 +143,6 @@ cgTopRhs bndr (StgRhsCon _cc con args) cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) = ASSERT(null fvs) -- There should be no free variables - setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $ forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body) diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 9f1f161d37..e4611237cc 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -180,15 +180,13 @@ cgLookupPanic :: Id -> FCode a cgLookupPanic id = do static_binds <- getStaticBinds local_binds <- getBinds - srt <- getSRTLabel - pprPanic "StgCmmEnv: variable not found" + pprPanic "StgCmmEnv: variable not found" (vcat [ppr id, ptext (sLit "static binds for:"), vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], ptext (sLit "local binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ], - ptext (sLit "SRT label") <+> ppr srt - ]) + vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] + ]) -------------------- diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 2290914310..39bd1feef1 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -39,8 +39,7 @@ module StgCmmMonad ( Sequel(..), ReturnKind(..), withSequel, getSequel, - setSRTLabel, getSRTLabel, - setTickyCtrLabel, getTickyCtrLabel, + setTickyCtrLabel, getTickyCtrLabel, withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, @@ -155,8 +154,7 @@ data CgInfoDownwards -- information only passed *downwards* by the monad cgd_dflags :: DynFlags, cgd_mod :: Module, -- Module being compiled cgd_statics :: CgBindings, -- [Id -> info] : static environment - cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT - cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame + cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame cgd_ticky :: CLabel, -- Current destination for ticky counts cgd_sequel :: Sequel -- What to do at end of basic block } @@ -285,8 +283,7 @@ initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags, cgd_mod = mod, cgd_statics = emptyVarEnv, - cgd_srt_lbl = error "initC: srt_lbl", - cgd_updfr_off = initUpdFrameOff, + cgd_updfr_off = initUpdFrameOff, cgd_ticky = mkTopTickyCtrLabel, cgd_sequel = initSequel } @@ -472,22 +469,6 @@ getSequel = do { info <- getInfoDown ; return (cgd_sequel info) } -- ---------------------------------------------------------------------------- --- Get/set the current SRT label - --- There is just one SRT for each top level binding; all the nested --- bindings use sub-sections of this SRT. The label is passed down to --- the nested bindings via the monad. - -getSRTLabel :: FCode CLabel -- Used only by cgPanic -getSRTLabel = do info <- getInfoDown - return (cgd_srt_lbl info) - -setSRTLabel :: CLabel -> FCode a -> FCode a -setSRTLabel srt_lbl code - = do info <- getInfoDown - withInfoDown code (info { cgd_srt_lbl = srt_lbl}) - --- ---------------------------------------------------------------------------- -- Get/set the size of the update frame -- We keep track of the size of the update frame so that we diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 22684126c2..6f9745dbfc 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1399,7 +1399,9 @@ tryNewCodeGen hsc_env this_mod data_tycons -- We are building a single SRT for the entire module, so -- we must thread it through all the procedures as we cps-convert them. us <- mkSplitUniqSupply 'S' - let initTopSRT = initUs_ us emptySRT + let srt_mod | dopt Opt_SplitObjs dflags = Just this_mod + | otherwise = Nothing + initTopSRT = initUs_ us (emptySRT srt_mod) let run_pipeline topSRT cmmgroup = do (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup |