Commit 3473e213 authored by Simon Marlow's avatar Simon Marlow

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.
parent 93faddc5
...@@ -13,7 +13,7 @@ module CLabel ( ...@@ -13,7 +13,7 @@ module CLabel (
mkClosureLabel, mkClosureLabel,
mkSRTLabel, mkSRTLabel,
mkModSRTLabel, mkTopSRTLabel,
mkInfoTableLabel, mkInfoTableLabel,
mkEntryLabel, mkEntryLabel,
mkSlowEntryLabel, mkSlowEntryLabel,
...@@ -120,8 +120,6 @@ import DynFlags ...@@ -120,8 +120,6 @@ import DynFlags
import Platform import Platform
import UniqSet import UniqSet
import Data.Maybe (isJust)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- The CLabel type -- The CLabel type
...@@ -218,7 +216,7 @@ data CLabel ...@@ -218,7 +216,7 @@ data CLabel
| HpcTicksLabel Module | HpcTicksLabel Module
-- | Static reference table -- | Static reference table
| SRTLabel (Maybe Module) !Unique | SRTLabel !Unique
-- | Label of an StgLargeSRT -- | Label of an StgLargeSRT
| LargeSRTLabel | LargeSRTLabel
...@@ -355,8 +353,8 @@ data DynamicLinkerLabelInfo ...@@ -355,8 +353,8 @@ data DynamicLinkerLabelInfo
mkSlowEntryLabel :: Name -> CafInfo -> CLabel mkSlowEntryLabel :: Name -> CafInfo -> CLabel
mkSlowEntryLabel name c = IdLabel name c Slow mkSlowEntryLabel name c = IdLabel name c Slow
mkModSRTLabel :: Maybe Module -> Unique -> CLabel mkTopSRTLabel :: Unique -> CLabel
mkModSRTLabel mb_mod u = SRTLabel mb_mod u mkTopSRTLabel u = SRTLabel u
mkSRTLabel :: Name -> CafInfo -> CLabel mkSRTLabel :: Name -> CafInfo -> CLabel
mkRednCountsLabel :: Name -> CafInfo -> CLabel mkRednCountsLabel :: Name -> CafInfo -> CLabel
...@@ -592,7 +590,7 @@ needsCDecl :: CLabel -> Bool ...@@ -592,7 +590,7 @@ needsCDecl :: CLabel -> Bool
-- False <=> it's pre-declared; don't bother -- False <=> it's pre-declared; don't bother
-- don't bother declaring Bitmap labels, we always make sure -- don't bother declaring Bitmap labels, we always make sure
-- they are defined before use. -- they are defined before use.
needsCDecl (SRTLabel _ _) = True needsCDecl (SRTLabel _) = True
needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeSRTLabel _) = False
needsCDecl (LargeBitmapLabel _) = False needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _ _) = True needsCDecl (IdLabel _ _ _) = True
...@@ -740,7 +738,7 @@ externallyVisibleCLabel (CCS_Label _) = True ...@@ -740,7 +738,7 @@ externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (SRTLabel mb_mod _) = isJust mb_mod externallyVisibleCLabel (SRTLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False
externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
...@@ -788,7 +786,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel ...@@ -788,7 +786,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (CaseLabel _ _) = CodeLabel labelType (CaseLabel _ _) = CodeLabel
labelType (PlainModuleInitLabel _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel
labelType (SRTLabel _ _) = DataLabel labelType (SRTLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel
labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
...@@ -991,10 +989,8 @@ pprCLbl (CaseLabel u (CaseAlt tag)) ...@@ -991,10 +989,8 @@ pprCLbl (CaseLabel u (CaseAlt tag))
pprCLbl (CaseLabel u CaseDefault) pprCLbl (CaseLabel u CaseDefault)
= hcat [pprUnique u, ptext (sLit "_dflt")] = hcat [pprUnique u, ptext (sLit "_dflt")]
pprCLbl (SRTLabel mb_mod u) pprCLbl (SRTLabel u)
= pp_mod <> pprUnique u <> pp_cSEP <> ptext (sLit "srt") = 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 (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd")
pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm") pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm")
......
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module CmmBuildInfoTables module CmmBuildInfoTables
( CAFSet, CAFEnv, cafAnal ( CAFSet, CAFEnv, cafAnal
, doSRTs, TopSRT, emptySRT, srtToData ) , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
where where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -31,7 +31,6 @@ import CmmInfo ...@@ -31,7 +31,6 @@ import CmmInfo
import Data.List import Data.List
import DynFlags import DynFlags
import Maybes import Maybes
import Module
import Outputable import Outputable
import SMRep import SMRep
import UniqSupply import UniqSupply
...@@ -136,11 +135,14 @@ instance Outputable TopSRT where ...@@ -136,11 +135,14 @@ instance Outputable TopSRT where
<+> ppr elts <+> ppr elts
<+> ppr eltmap <+> ppr eltmap
emptySRT :: MonadUnique m => Maybe Module -> m TopSRT emptySRT :: MonadUnique m => m TopSRT
emptySRT mb_mod = emptySRT =
do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty } 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 :: TopSRT -> CLabel -> Bool
cafMember srt lbl = Map.member lbl (elt_map srt) cafMember srt lbl = Map.member lbl (elt_map srt)
......
...@@ -136,7 +136,6 @@ import Fingerprint ( Fingerprint ) ...@@ -136,7 +136,6 @@ import Fingerprint ( Fingerprint )
import DynFlags import DynFlags
import ErrUtils import ErrUtils
import UniqSupply ( mkSplitUniqSupply )
import Outputable import Outputable
import HscStats ( ppSourceStats ) import HscStats ( ppSourceStats )
...@@ -144,7 +143,7 @@ import HscTypes ...@@ -144,7 +143,7 @@ import HscTypes
import MkExternalCore ( emitExternalCore ) import MkExternalCore ( emitExternalCore )
import FastString import FastString
import UniqFM ( emptyUFM ) import UniqFM ( emptyUFM )
import UniqSupply ( initUs_ ) import UniqSupply
import Bag import Bag
import Exception import Exception
import qualified Stream import qualified Stream
...@@ -1399,17 +1398,33 @@ tryNewCodeGen hsc_env this_mod data_tycons ...@@ -1399,17 +1398,33 @@ tryNewCodeGen hsc_env this_mod data_tycons
-- We are building a single SRT for the entire module, so -- We are building a single SRT for the entire module, so
-- we must thread it through all the procedures as we cps-convert them. -- we must thread it through all the procedures as we cps-convert them.
us <- mkSplitUniqSupply 'S' 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 -- When splitting, we generate one SRT per split chunk, otherwise
(topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup -- we generate one SRT for the whole module.
return (topSRT,cmmOfZgraph cmmgroup) let
pipeline_stream
let pipeline_stream = {-# SCC "cmmPipeline" #-} do | dopt Opt_SplitObjs dflags
topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 = {-# SCC "cmmPipeline" #-}
Stream.yield (cmmOfZgraph (srtToData topSRT)) 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 let
dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment