Commit ceffd7fe authored by Ben Gamari's avatar Ben Gamari 🐢

Revert "An overhaul of the SRT representation"

This reverts commit eb8e692c.
parent dee22948
...@@ -14,11 +14,12 @@ module CLabel ( ...@@ -14,11 +14,12 @@ module CLabel (
pprDebugCLabel, pprDebugCLabel,
mkClosureLabel, mkClosureLabel,
mkSRTLabel, mkTopSRTLabel,
mkInfoTableLabel, mkInfoTableLabel,
mkEntryLabel, mkEntryLabel,
mkRednCountsLabel, mkRednCountsLabel,
mkConInfoTableLabel, mkConInfoTableLabel,
mkLargeSRTLabel,
mkApEntryLabel, mkApEntryLabel,
mkApInfoTableLabel, mkApInfoTableLabel,
mkClosureTableLabel, mkClosureTableLabel,
...@@ -53,7 +54,6 @@ module CLabel ( ...@@ -53,7 +54,6 @@ module CLabel (
mkSMAP_DIRTY_infoLabel, mkSMAP_DIRTY_infoLabel,
mkBadAlignmentLabel, mkBadAlignmentLabel,
mkArrWords_infoLabel, mkArrWords_infoLabel,
mkSRTInfoLabel,
mkTopTickyCtrLabel, mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleInfoTableLabel,
...@@ -250,7 +250,10 @@ data CLabel ...@@ -250,7 +250,10 @@ data CLabel
| HpcTicksLabel Module | HpcTicksLabel Module
-- | Static reference table -- | Static reference table
| SRTLabel | SRTLabel !Unique
-- | Label of an StgLargeSRT
| LargeSRTLabel
{-# UNPACK #-} !Unique {-# UNPACK #-} !Unique
-- | A bitmap (function or case return) -- | A bitmap (function or case return)
...@@ -300,6 +303,8 @@ instance Ord CLabel where ...@@ -300,6 +303,8 @@ instance Ord CLabel where
compare a1 a2 compare a1 a2
compare (SRTLabel u1) (SRTLabel u2) = compare (SRTLabel u1) (SRTLabel u2) =
nonDetCmpUnique u1 u2 nonDetCmpUnique u1 u2
compare (LargeSRTLabel u1) (LargeSRTLabel u2) =
nonDetCmpUnique u1 u2
compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) = compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =
nonDetCmpUnique u1 u2 nonDetCmpUnique u1 u2
compare IdLabel{} _ = LT compare IdLabel{} _ = LT
...@@ -332,6 +337,8 @@ instance Ord CLabel where ...@@ -332,6 +337,8 @@ instance Ord CLabel where
compare _ HpcTicksLabel{} = GT compare _ HpcTicksLabel{} = GT
compare SRTLabel{} _ = LT compare SRTLabel{} _ = LT
compare _ SRTLabel{} = GT compare _ SRTLabel{} = GT
compare LargeSRTLabel{} _ = LT
compare _ LargeSRTLabel{} = GT
-- | Record where a foreign label is stored. -- | Record where a foreign label is stored.
data ForeignLabelSource data ForeignLabelSource
...@@ -380,6 +387,9 @@ pprDebugCLabel lbl ...@@ -380,6 +387,9 @@ pprDebugCLabel lbl
data IdLabelInfo data IdLabelInfo
= Closure -- ^ Label for closure = Closure -- ^ Label for closure
| 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 | InfoTable -- ^ Info tables for closures; always read-only
| Entry -- ^ Entry point | Entry -- ^ Entry point
| Slow -- ^ Slow entry point | Slow -- ^ Slow entry point
...@@ -449,8 +459,8 @@ data DynamicLinkerLabelInfo ...@@ -449,8 +459,8 @@ data DynamicLinkerLabelInfo
-- Constructing IdLabels -- Constructing IdLabels
-- These are always local: -- These are always local:
mkSRTLabel :: Unique -> CLabel mkTopSRTLabel :: Unique -> CLabel
mkSRTLabel u = SRTLabel u mkTopSRTLabel u = SRTLabel u
mkRednCountsLabel :: Name -> CLabel mkRednCountsLabel :: Name -> CLabel
mkRednCountsLabel name = mkRednCountsLabel name =
...@@ -508,29 +518,6 @@ mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_P ...@@ -508,29 +518,6 @@ mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_P
mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
mkBadAlignmentLabel = CmmLabel rtsUnitId (fsLit "stg_badAlignment") CmmEntry mkBadAlignmentLabel = CmmLabel rtsUnitId (fsLit "stg_badAlignment") CmmEntry
mkSRTInfoLabel :: Int -> CLabel
mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
where
lbl =
case n of
1 -> fsLit "stg_SRT_1"
2 -> fsLit "stg_SRT_2"
3 -> fsLit "stg_SRT_3"
4 -> fsLit "stg_SRT_4"
5 -> fsLit "stg_SRT_5"
6 -> fsLit "stg_SRT_6"
7 -> fsLit "stg_SRT_7"
8 -> fsLit "stg_SRT_8"
9 -> fsLit "stg_SRT_9"
10 -> fsLit "stg_SRT_10"
11 -> fsLit "stg_SRT_11"
12 -> fsLit "stg_SRT_12"
13 -> fsLit "stg_SRT_13"
14 -> fsLit "stg_SRT_14"
15 -> fsLit "stg_SRT_15"
16 -> fsLit "stg_SRT_16"
_ -> panic "mkSRTInfoLabel"
----- -----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel
...@@ -615,6 +602,9 @@ isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True ...@@ -615,6 +602,9 @@ isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True
isSomeRODataLabel (IdLabel _ _ InfoTable) = True isSomeRODataLabel (IdLabel _ _ InfoTable) = True
isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
-- static reference tables defined in haskell (.hs)
isSomeRODataLabel (IdLabel _ _ SRT) = True
isSomeRODataLabel (SRTLabel _) = True
-- info table defined in cmm (.cmm) -- info table defined in cmm (.cmm)
isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True
isSomeRODataLabel _lbl = False isSomeRODataLabel _lbl = False
...@@ -626,7 +616,9 @@ foreignLabelStdcallInfo _lbl = Nothing ...@@ -626,7 +616,9 @@ foreignLabelStdcallInfo _lbl = Nothing
-- Constructing Large*Labels -- Constructing Large*Labels
mkLargeSRTLabel :: Unique -> CLabel
mkBitmapLabel :: Unique -> CLabel mkBitmapLabel :: Unique -> CLabel
mkLargeSRTLabel uniq = LargeSRTLabel uniq
mkBitmapLabel uniq = LargeBitmapLabel uniq mkBitmapLabel uniq = LargeBitmapLabel uniq
-- Constructing Cost Center Labels -- Constructing Cost Center Labels
...@@ -684,6 +676,8 @@ mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die") ...@@ -684,6 +676,8 @@ mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")
-- Convert between different kinds of label -- Convert between different kinds of label
toClosureLbl :: CLabel -> CLabel toClosureLbl :: CLabel -> CLabel
toClosureLbl (IdLabel n _ BlockInfoTable)
= pprPanic "toClosureLbl: BlockInfoTable" (ppr n)
toClosureLbl (IdLabel n c _) = IdLabel n c Closure toClosureLbl (IdLabel n c _) = IdLabel n c Closure
toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
toClosureLbl l = pprPanic "toClosureLbl" (ppr l) toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
...@@ -752,6 +746,7 @@ needsCDecl :: CLabel -> Bool ...@@ -752,6 +746,7 @@ needsCDecl :: CLabel -> Bool
-- 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 (LargeBitmapLabel _) = False needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _ _) = True needsCDecl (IdLabel _ _ _) = True
needsCDecl (LocalBlockLabel _) = True needsCDecl (LocalBlockLabel _) = True
...@@ -898,10 +893,12 @@ externallyVisibleCLabel (DynamicLinkerLabel _ _) = False ...@@ -898,10 +893,12 @@ externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (SRTLabel _) = False externallyVisibleCLabel (SRTLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False
externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel" externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer" externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
externallyVisibleIdLabel :: IdLabelInfo -> Bool externallyVisibleIdLabel :: IdLabelInfo -> Bool
externallyVisibleIdLabel SRT = False
externallyVisibleIdLabel LocalInfoTable = False externallyVisibleIdLabel LocalInfoTable = False
externallyVisibleIdLabel LocalEntry = False externallyVisibleIdLabel LocalEntry = False
externallyVisibleIdLabel BlockInfoTable = False externallyVisibleIdLabel BlockInfoTable = False
...@@ -957,6 +954,7 @@ labelType (DynamicLinkerLabel _ _) = DataLabel -- Is this right? ...@@ -957,6 +954,7 @@ labelType (DynamicLinkerLabel _ _) = DataLabel -- Is this right?
labelType PicBaseLabel = DataLabel labelType PicBaseLabel = DataLabel
labelType (DeadStripPreventer _) = DataLabel labelType (DeadStripPreventer _) = DataLabel
labelType (HpcTicksLabel _) = DataLabel labelType (HpcTicksLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel
idInfoLabelType :: IdLabelInfo -> CLabelType idInfoLabelType :: IdLabelInfo -> CLabelType
...@@ -1045,6 +1043,7 @@ internal names. <type> is one of the following: ...@@ -1045,6 +1043,7 @@ internal names. <type> is one of the following:
info Info table info Info table
srt Static reference table srt Static reference table
srtd Static reference table descriptor
entry Entry code (function, closure) entry Entry code (function, closure)
slow Slow entry code (if any) slow Slow entry code (if any)
ret Direct return address ret Direct return address
...@@ -1183,6 +1182,7 @@ pprCLbl (StringLitLabel u) ...@@ -1183,6 +1182,7 @@ pprCLbl (StringLitLabel u)
pprCLbl (SRTLabel u) pprCLbl (SRTLabel u)
= pprUniqueAlways u <> pp_cSEP <> text "srt" = pprUniqueAlways u <> pp_cSEP <> text "srt"
pprCLbl (LargeSRTLabel u) = pprUniqueAlways u <> pp_cSEP <> text "srtd"
pprCLbl (LargeBitmapLabel u) = text "b" <> pprUniqueAlways u <> pp_cSEP <> text "btm" pprCLbl (LargeBitmapLabel u) = text "b" <> pprUniqueAlways u <> pp_cSEP <> text "btm"
-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7') -- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
-- until that gets resolved we'll just force them to start -- until that gets resolved we'll just force them to start
...@@ -1275,6 +1275,7 @@ ppIdFlavor :: IdLabelInfo -> SDoc ...@@ -1275,6 +1275,7 @@ ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <> ppIdFlavor x = pp_cSEP <>
(case x of (case x of
Closure -> text "closure" Closure -> text "closure"
SRT -> text "srt"
InfoTable -> text "info" InfoTable -> text "info"
LocalInfoTable -> text "info" LocalInfoTable -> text "info"
Entry -> text "entry" Entry -> text "entry"
......
...@@ -18,6 +18,7 @@ module Cmm ( ...@@ -18,6 +18,7 @@ module Cmm (
-- * Info Tables -- * Info Tables
CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable, CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
ClosureTypeInfo(..), ClosureTypeInfo(..),
C_SRT(..), needsSRT,
ProfilingInfo(..), ConstrDescription, ProfilingInfo(..), ConstrDescription,
-- * Statements, expressions and types -- * Statements, expressions and types
...@@ -137,13 +138,24 @@ data CmmInfoTable ...@@ -137,13 +138,24 @@ data CmmInfoTable
cit_lbl :: CLabel, -- Info table label cit_lbl :: CLabel, -- Info table label
cit_rep :: SMRep, cit_rep :: SMRep,
cit_prof :: ProfilingInfo, cit_prof :: ProfilingInfo,
cit_srt :: Maybe CLabel -- empty, or a closure address cit_srt :: C_SRT
} }
data ProfilingInfo data ProfilingInfo
= NoProfilingInfo = NoProfilingInfo
| ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc
-- C_SRT is what StgSyn.SRT gets translated to...
-- we add a label for the table, and expect only the 'offset/length' form
data C_SRT = NoC_SRT
| C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
deriving (Eq)
needsSRT :: C_SRT -> Bool
needsSRT NoC_SRT = False
needsSRT (C_SRT _ _ _) = True
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Static Data -- Static Data
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
......
This diff is collapsed.
...@@ -62,7 +62,7 @@ mkEmptyContInfoTable info_lbl ...@@ -62,7 +62,7 @@ mkEmptyContInfoTable info_lbl
= CmmInfoTable { cit_lbl = info_lbl = CmmInfoTable { cit_lbl = info_lbl
, cit_rep = mkStackRep [] , cit_rep = mkStackRep []
, cit_prof = NoProfilingInfo , cit_prof = NoProfilingInfo
, cit_srt = Nothing } , cit_srt = NoC_SRT }
cmmToRawCmm :: DynFlags -> Stream IO CmmGroup () cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
-> IO (Stream IO RawCmmGroup ()) -> IO (Stream IO RawCmmGroup ())
...@@ -255,11 +255,12 @@ packIntsCLit dflags a b = packHalfWordsCLit dflags ...@@ -255,11 +255,12 @@ packIntsCLit dflags a b = packHalfWordsCLit dflags
mkSRTLit :: DynFlags mkSRTLit :: DynFlags
-> Maybe CLabel -> C_SRT
-> ([CmmLit], -- srt_label, if any -> ([CmmLit], -- srt_label, if any
StgHalfWord) -- srt_bitmap StgHalfWord) -- srt_bitmap
mkSRTLit dflags Nothing = ([], toStgHalfWord dflags 0) mkSRTLit dflags NoC_SRT = ([], toStgHalfWord dflags 0)
mkSRTLit dflags (Just lbl) = ([CmmLabel lbl], toStgHalfWord dflags 1) mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
------------------------------------------------------------------------- -------------------------------------------------------------------------
-- --
......
...@@ -470,7 +470,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -470,7 +470,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
return (mkCmmEntryLabel pkg $3, return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep , cit_rep = rep
, cit_prof = prof, cit_srt = Nothing }, , cit_prof = prof, cit_srt = NoC_SRT },
[]) } []) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
...@@ -486,7 +486,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -486,7 +486,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
return (mkCmmEntryLabel pkg $3, return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep , cit_rep = rep
, cit_prof = prof, cit_srt = Nothing }, , cit_prof = prof, cit_srt = NoC_SRT },
[]) } []) }
-- we leave most of the fields zero here. This is only used -- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment. -- to generate the BCO info table in the RTS at the moment.
...@@ -504,7 +504,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -504,7 +504,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
return (mkCmmEntryLabel pkg $3, return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep , cit_rep = rep
, cit_prof = prof, cit_srt = Nothing }, , cit_prof = prof, cit_srt = NoC_SRT },
[]) } []) }
-- If profiling is on, this string gets duplicated, -- If profiling is on, this string gets duplicated,
...@@ -521,7 +521,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -521,7 +521,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
return (mkCmmEntryLabel pkg $3, return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep , cit_rep = rep
, cit_prof = prof, cit_srt = Nothing }, , cit_prof = prof, cit_srt = NoC_SRT },
[]) } []) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')' | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
...@@ -532,7 +532,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -532,7 +532,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
return (mkCmmRetLabel pkg $3, return (mkCmmRetLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
, cit_rep = rep , cit_rep = rep
, cit_prof = prof, cit_srt = Nothing }, , cit_prof = prof, cit_srt = NoC_SRT },
[]) } []) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
...@@ -547,7 +547,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -547,7 +547,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
return (mkCmmRetLabel pkg $3, return (mkCmmRetLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
, cit_rep = rep , cit_rep = rep
, cit_prof = prof, cit_srt = Nothing }, , cit_prof = prof, cit_srt = NoC_SRT },
live) } live) }
body :: { CmmParse () } body :: { CmmParse () }
......
...@@ -32,22 +32,21 @@ import Platform ...@@ -32,22 +32,21 @@ import Platform
-- | Top level driver for C-- pipeline -- | Top level driver for C-- pipeline
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
cmmPipeline cmmPipeline :: HscEnv -- Compilation env including
:: HscEnv -- Compilation env including -- dynamic flags: -dcmm-lint -ddump-cmm-cps
-- dynamic flags: -dcmm-lint -ddump-cmm-cps -> TopSRT -- SRT table and accumulating list of compiled procs
-> ModuleSRTInfo -- Info about SRTs generated so far -> CmmGroup -- Input C-- with Procedures
-> CmmGroup -- Input C-- with Procedures -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
-> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
cmmPipeline hsc_env topSRT prog =
cmmPipeline hsc_env srtInfo prog =
do let dflags = hsc_dflags hsc_env do let dflags = hsc_dflags hsc_env
tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
(srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops
dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms) dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)
return (srtInfo, cmms) return (topSRT, cmms)
cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
...@@ -106,7 +105,7 @@ cpsTop hsc_env proc = ...@@ -106,7 +105,7 @@ cpsTop hsc_env proc =
Opt_D_dump_cmm_sink "Sink assignments" Opt_D_dump_cmm_sink "Sink assignments"
------------- CAF analysis ---------------------------------------------- ------------- CAF analysis ----------------------------------------------
let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv) dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)
g <- if splitting_proc_points g <- if splitting_proc_points
......
...@@ -30,7 +30,6 @@ module Hoopl.Dataflow ...@@ -30,7 +30,6 @@ module Hoopl.Dataflow
, rewriteCmmBwd , rewriteCmmBwd
, changedIf , changedIf
, joinOutFacts , joinOutFacts
, joinFacts
) )
where where
...@@ -375,11 +374,6 @@ joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts ...@@ -375,11 +374,6 @@ joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
, isJust fact , isJust fact
] ]
joinFacts :: DataflowLattice f -> [f] -> f
joinFacts lattice facts = foldl' join (fact_bot lattice) facts
where
join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
-- | Returns the joined facts for each label. -- | Returns the joined facts for each label.
mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
mkFactBase lattice = foldl' add mapEmpty mkFactBase lattice = foldl' add mapEmpty
......
...@@ -108,7 +108,7 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = ...@@ -108,7 +108,7 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
pprTopInfo :: CmmTopInfo -> SDoc pprTopInfo :: CmmTopInfo -> SDoc
pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
vcat [text "info_tbls: " <> ppr info_tbl, vcat [text "info_tbl: " <> ppr info_tbl,
text "stack_info: " <> ppr stack_info] text "stack_info: " <> ppr stack_info]
---------------------------------------------------------- ----------------------------------------------------------
......
...@@ -115,15 +115,18 @@ pprTop (CmmData section ds) = ...@@ -115,15 +115,18 @@ pprTop (CmmData section ds) =
pprInfoTable :: CmmInfoTable -> SDoc pprInfoTable :: CmmInfoTable -> SDoc
pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
, cit_prof = prof_info , cit_prof = prof_info
, cit_srt = srt }) , cit_srt = _srt })
= vcat [ text "label: " <> ppr lbl = vcat [ text "label:" <+> ppr lbl
, text "rep: " <> ppr rep , text "rep:" <> ppr rep
, case prof_info of , case prof_info of
NoProfilingInfo -> empty NoProfilingInfo -> empty
ProfilingInfo ct cd -> ProfilingInfo ct cd -> vcat [ text "type:" <+> pprWord8String ct
vcat [ text "type: " <> pprWord8String ct , text "desc: " <> pprWord8String cd ] ]
, text "desc: " <> pprWord8String cd ]
, text "srt: " <> ppr srt ] instance Outputable C_SRT where
ppr NoC_SRT = text "_no_srt_"
ppr (C_SRT label off bitmap)
= parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap)
instance Outputable ForeignHint where instance Outputable ForeignHint where
ppr NoHint = empty ppr NoHint = empty
......
...@@ -750,7 +750,7 @@ mkCmmInfo ClosureInfo {..} ...@@ -750,7 +750,7 @@ mkCmmInfo ClosureInfo {..}
= CmmInfoTable { cit_lbl = closureInfoLabel = CmmInfoTable { cit_lbl = closureInfoLabel
, cit_rep = closureSMRep , cit_rep = closureSMRep
, cit_prof = closureProf , cit_prof = closureProf
, cit_srt = Nothing } , cit_srt = NoC_SRT }
-------------------------------------- --------------------------------------
-- Building ClosureInfos -- Building ClosureInfos
...@@ -1035,7 +1035,7 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds ...@@ -1035,7 +1035,7 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
= CmmInfoTable { cit_lbl = info_lbl = CmmInfoTable { cit_lbl = info_lbl
, cit_rep = sm_rep , cit_rep = sm_rep
, cit_prof = prof , cit_prof = prof
, cit_srt = Nothing } , cit_srt = NoC_SRT }
where where
name = dataConName data_con name = dataConName data_con
info_lbl = mkConInfoTableLabel name NoCafRefs info_lbl = mkConInfoTableLabel name NoCafRefs
...@@ -1058,14 +1058,14 @@ cafBlackHoleInfoTable ...@@ -1058,14 +1058,14 @@ cafBlackHoleInfoTable
= CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel = CmmInfoTable { cit_lbl = mkCAFBlackHoleInfoTableLabel
, cit_rep = blackHoleRep , cit_rep = blackHoleRep
, cit_prof = NoProfilingInfo , cit_prof = NoProfilingInfo
, cit_srt = Nothing } , cit_srt = NoC_SRT }
indStaticInfoTable :: CmmInfoTable indStaticInfoTable :: CmmInfoTable
indStaticInfoTable indStaticInfoTable
= CmmInfoTable { cit_lbl = mkIndStaticInfoLabel = CmmInfoTable { cit_lbl = mkIndStaticInfoLabel
, cit_rep = indStaticRep , cit_rep = indStaticRep
, cit_prof = NoProfilingInfo , cit_prof = NoProfilingInfo
, cit_srt = Nothing } , cit_srt = NoC_SRT }
staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
-- A static closure needs a link field to aid the GC when traversing -- A static closure needs a link field to aid the GC when traversing
...@@ -1076,4 +1076,4 @@ staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool ...@@ -1076,4 +1076,4 @@ staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
-- of the SRT. -- of the SRT.
staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep } staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
| isConRep smrep = not (isStaticNoCafCon smrep) | isConRep smrep = not (isStaticNoCafCon smrep)
| otherwise = has_srt | otherwise = has_srt -- needsSRT (cit_srt info_tbl)
...@@ -1397,13 +1397,15 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do ...@@ -1397,13 +1397,15 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env let dflags = hsc_dflags hsc_env
cmm <- ioMsgMaybe $ parseCmmFile dflags filename cmm <- ioMsgMaybe $ parseCmmFile dflags filename
liftIO $ do liftIO $ do
us <- mkSplitUniqSupply 'S'
let initTopSRT = initUs_ us emptySRT
dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm) dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)
(_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
let -- Make up a module name to give the NCG. We can't pass bottom here let -- Make up a module name to give the NCG. We can't pass bottom here
-- lest we reproduce #11784. -- lest we reproduce #11784.
mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
cmm_mod = mkModule (thisPackage dflags) mod_name cmm_mod = mkModule (thisPackage dflags) mod_name
(_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm
rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
_ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
rawCmms rawCmms
return () return ()
...@@ -1454,17 +1456,21 @@ doCodeGen hsc_env this_mod data_tycons ...@@ -1454,17 +1456,21 @@ doCodeGen hsc_env this_mod data_tycons
osSubsectionsViaSymbols (platformOS (targetPlatform dflags)) osSubsectionsViaSymbols (platformOS (targetPlatform dflags))
= {-# SCC "cmmPipeline" #-} = {-# SCC "cmmPipeline" #-}
let run_pipeline us cmmgroup = do let run_pipeline us cmmgroup = do
(_topSRT, cmmgroup) <- let (topSRT', us') = initUs us emptySRT
cmmPipeline hsc_env (emptySRT this_mod) cmmgroup (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
return (us, cmmgroup) let srt | isEmptySRT topSRT = []
| otherwise = srtToData topSRT
return (us', srt ++ cmmgroup)
in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1 in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
return () return ()
| otherwise | otherwise
= {-# SCC "cmmPipeline" #-} = {-# SCC "cmmPipeline" #-}
let run_pipeline = cmmPipeline hsc_env let initTopSRT = initUs_ us emptySRT
in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 run_pipeline = cmmPipeline hsc_env
in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
Stream.yield (srtToData topSRT)
let let
dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
......
...@@ -131,6 +131,15 @@ import Control.Monad (liftM, ap) ...@@ -131,6 +131,15 @@ import Control.Monad (liftM, ap)
-- --
-- The CafInfo has already been calculated during the CoreTidy pass. -- The CafInfo has already been calculated during the CoreTidy pass.
-- --
-- During CoreToStg, we then pin onto each binding and case expression, a
-- list of Ids which represents the "live" CAFs at that point. The meaning
-- of "live" here is the same as for live variables, see above (which is
-- why it's convenient to collect CAF information here rather than elsewhere).
--
-- The later SRT pass takes these lists of Ids and uses them to construct
-- the actual nested SRTs, and replaces the lists of Ids with (offset,length)
-- pairs.
-- Note [What is a non-escaping let] -- Note [What is a non-escaping let]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- --
......
...@@ -109,7 +109,7 @@ INLINE_HEADER const StgConInfoTable *get_con_itbl(const StgClosure *c) ...@@ -109,7 +109,7 @@ INLINE_HEADER const StgConInfoTable *get_con_itbl(const StgClosure *c)
INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con) INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con)
{ {
return get_itbl(con)->has_srt; return get_itbl(con)->srt_bitmap;
} }