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 (
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")
......
......@@ -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)
......
......@@ -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
......
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