Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/3473e213941b74a1074ec0cde77c0eeccf885e03 >--------------------------------------------------------------- commit 3473e213941b74a1074ec0cde77c0eeccf885e03 Author: Simon Marlow <[email protected]> Date: Tue Sep 25 16:02:45 2012 +0100 When -split-objs is on, make one SRT per split, not one per module This is a hopefully temporary measure until the new SRT design is implemeented. >--------------------------------------------------------------- compiler/cmm/CLabel.hs | 22 ++++++++------------ compiler/cmm/CmmBuildInfoTables.hs | 12 ++++++---- compiler/main/HscMain.hs | 39 ++++++++++++++++++++++++----------- 3 files changed, 43 insertions(+), 30 deletions(-) diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 1ff76c6..a5d559e 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -13,7 +13,7 @@ module CLabel ( mkClosureLabel, mkSRTLabel, - mkModSRTLabel, + mkTopSRTLabel, mkInfoTableLabel, mkEntryLabel, mkSlowEntryLabel, @@ -120,8 +120,6 @@ import DynFlags import Platform import UniqSet -import Data.Maybe (isJust) - -- ----------------------------------------------------------------------------- -- The CLabel type @@ -218,7 +216,7 @@ data CLabel | HpcTicksLabel Module -- | Static reference table - | SRTLabel (Maybe Module) !Unique + | SRTLabel !Unique -- | Label of an StgLargeSRT | LargeSRTLabel @@ -355,8 +353,8 @@ 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 +mkTopSRTLabel :: Unique -> CLabel +mkTopSRTLabel u = SRTLabel u mkSRTLabel :: Name -> CafInfo -> CLabel mkRednCountsLabel :: Name -> CafInfo -> CLabel @@ -592,7 +590,7 @@ needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother -- don't bother declaring Bitmap labels, we always make sure -- they are defined before use. -needsCDecl (SRTLabel _ _) = True +needsCDecl (SRTLabel _) = True needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _ _) = True @@ -740,7 +738,7 @@ externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (HpcTicksLabel _) = True externallyVisibleCLabel (LargeBitmapLabel _) = False -externallyVisibleCLabel (SRTLabel mb_mod _) = isJust mb_mod +externallyVisibleCLabel (SRTLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" @@ -788,7 +786,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel -labelType (SRTLabel _ _) = DataLabel +labelType (SRTLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@ -991,10 +989,8 @@ 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 (SRTLabel u) + = pprUnique u <> pp_cSEP <> ptext (sLit "srt") pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd") pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm") diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 54edb73..ecaab57 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -14,7 +14,7 @@ {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module CmmBuildInfoTables ( CAFSet, CAFEnv, cafAnal - , doSRTs, TopSRT, emptySRT, srtToData ) + , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData ) where #include "HsVersions.h" @@ -31,7 +31,6 @@ import CmmInfo import Data.List import DynFlags import Maybes -import Module import Outputable import SMRep import UniqSupply @@ -136,11 +135,14 @@ instance Outputable TopSRT where <+> ppr elts <+> ppr eltmap -emptySRT :: MonadUnique m => Maybe Module -> m TopSRT -emptySRT mb_mod = - do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u +emptySRT :: MonadUnique m => m TopSRT +emptySRT = + do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty } +isEmptySRT :: TopSRT -> Bool +isEmptySRT srt = null (rev_elts srt) + cafMember :: TopSRT -> CLabel -> Bool cafMember srt lbl = Map.member lbl (elt_map srt) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 6f9745d..5c3fa0d 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -136,7 +136,6 @@ import Fingerprint ( Fingerprint ) import DynFlags import ErrUtils -import UniqSupply ( mkSplitUniqSupply ) import Outputable import HscStats ( ppSourceStats ) @@ -144,7 +143,7 @@ import HscTypes import MkExternalCore ( emitExternalCore ) import FastString import UniqFM ( emptyUFM ) -import UniqSupply ( initUs_ ) +import UniqSupply import Bag import Exception import qualified Stream @@ -1399,17 +1398,33 @@ 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 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 - return (topSRT,cmmOfZgraph cmmgroup) - - let pipeline_stream = {-# SCC "cmmPipeline" #-} do - topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 - Stream.yield (cmmOfZgraph (srtToData topSRT)) + -- When splitting, we generate one SRT per split chunk, otherwise + -- we generate one SRT for the whole module. + let + pipeline_stream + | dopt Opt_SplitObjs dflags + = {-# SCC "cmmPipeline" #-} + let run_pipeline us cmmgroup = do + let (topSRT', us') = initUs us emptySRT + (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup + let srt | isEmptySRT topSRT = [] + | otherwise = srtToData topSRT + return (us',cmmOfZgraph (srt ++ cmmgroup)) + + in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1 + return () + + | otherwise + = {-# SCC "cmmPipeline" #-} + let initTopSRT = initUs_ us emptySRT in + + let run_pipeline topSRT cmmgroup = do + (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup + return (topSRT,cmmOfZgraph cmmgroup) + + in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 + Stream.yield (cmmOfZgraph (srtToData topSRT)) let dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
