Commit 2bb099e5 authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

BlockId: remove BlockMap and BlockSet synonyms

This continues removal of `BlockId` module in favor of Hoopl's `Label`.
Most of the changes here are mechanical, apart from the orphan
`Outputable` instances for `LabelMap` and `LabelSet`.  For now I've
moved them to `cmm/Hoopl`, since it's already trying to manage all
imports from Hoopl (to avoid any collisions).
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan: validate

Reviewers: bgamari, austin, simonmar

Reviewed By: simonmar

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2800
parent 55361b38
...@@ -5,9 +5,6 @@ ...@@ -5,9 +5,6 @@
module BlockId module BlockId
( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
, newBlockId , newBlockId
, BlockSet, BlockEnv
, IsSet(..)
, IsMap(..)
, blockLbl, infoTblLbl , blockLbl, infoTblLbl
) where ) where
...@@ -52,15 +49,3 @@ blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs ...@@ -52,15 +49,3 @@ blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
infoTblLbl :: BlockId -> CLabel infoTblLbl :: BlockId -> CLabel
infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
-- Block environments: Id blocks
type BlockEnv a = Hoopl.LabelMap a
instance Outputable a => Outputable (BlockEnv a) where
ppr = ppr . mapToList
-- Block sets
type BlockSet = Hoopl.LabelSet
instance Outputable BlockSet where
ppr = ppr . setElems
...@@ -57,7 +57,7 @@ type CmmProgram = [CmmGroup] ...@@ -57,7 +57,7 @@ type CmmProgram = [CmmGroup]
type GenCmmGroup d h g = [GenCmmDecl d h g] type GenCmmGroup d h g = [GenCmmDecl d h g]
type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) CmmGraph type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- CmmDecl, GenCmmDecl -- CmmDecl, GenCmmDecl
...@@ -94,7 +94,7 @@ type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph ...@@ -94,7 +94,7 @@ type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
type RawCmmDecl type RawCmmDecl
= GenCmmDecl = GenCmmDecl
CmmStatics CmmStatics
(BlockEnv CmmStatics) (LabelMap CmmStatics)
CmmGraph CmmGraph
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
...@@ -114,7 +114,7 @@ type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f ...@@ -114,7 +114,7 @@ type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f
-- Info Tables -- Info Tables
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable
, stack_info :: CmmStackInfo } , stack_info :: CmmStackInfo }
topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
......
...@@ -9,7 +9,6 @@ where ...@@ -9,7 +9,6 @@ where
import Hoopl import Hoopl
import Digraph import Digraph
import BlockId
import Bitmap import Bitmap
import CLabel import CLabel
import PprCmmDecl () import PprCmmDecl ()
...@@ -83,7 +82,7 @@ This is what flattenCAFSets is doing. ...@@ -83,7 +82,7 @@ This is what flattenCAFSets is doing.
-- Finding the CAFs used by a procedure -- Finding the CAFs used by a procedure
type CAFSet = Set CLabel type CAFSet = Set CLabel
type CAFEnv = BlockEnv CAFSet type CAFEnv = LabelMap CAFSet
cafLattice :: DataflowLattice CAFSet cafLattice :: DataflowLattice CAFSet
cafLattice = DataflowLattice Set.empty add cafLattice = DataflowLattice Set.empty add
...@@ -292,7 +291,7 @@ flatten env cafset = foldSet (lookup env) Set.empty cafset ...@@ -292,7 +291,7 @@ flatten env cafset = foldSet (lookup env) Set.empty cafset
bundle :: Map CLabel CAFSet bundle :: Map CLabel CAFSet
-> (CAFEnv, CmmDecl) -> (CAFEnv, CmmDecl)
-> (CAFSet, Maybe CLabel) -> (CAFSet, Maybe CLabel)
-> (BlockEnv CAFSet, CmmDecl) -> (LabelMap CAFSet, CmmDecl)
bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl) bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl)
= ( mapMapWithKey get_cafs (info_tbls infos), decl ) = ( mapMapWithKey get_cafs (info_tbls infos), decl )
where where
...@@ -316,7 +315,7 @@ bundle _flatmap (_, decl) _ ...@@ -316,7 +315,7 @@ bundle _flatmap (_, decl) _
= ( mapEmpty, decl ) = ( mapEmpty, decl )
flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(BlockEnv CAFSet, CmmDecl)] flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(LabelMap CAFSet, CmmDecl)]
flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
where where
zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ] zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
...@@ -342,8 +341,8 @@ doSRTs dflags topSRT tops ...@@ -342,8 +341,8 @@ doSRTs dflags topSRT tops
setSRT (topSRT, rst) (_, decl) = setSRT (topSRT, rst) (_, decl) =
return (topSRT, decl : rst) return (topSRT, decl : rst)
buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet buildSRTs :: DynFlags -> TopSRT -> LabelMap CAFSet
-> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT) -> UniqSM (TopSRT, [CmmDecl], LabelMap C_SRT)
buildSRTs dflags top_srt caf_map buildSRTs dflags top_srt caf_map
= foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map) = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
where where
...@@ -359,7 +358,7 @@ buildSRTs dflags top_srt caf_map ...@@ -359,7 +358,7 @@ buildSRTs dflags top_srt caf_map
- Each one needs an SRT. - Each one needs an SRT.
- We get the CAFSet for each one from the CAFEnv - We get the CAFSet for each one from the CAFEnv
- flatten gives us - flatten gives us
[(BlockEnv CAFSet, CmmDecl)] [(LabelMap CAFSet, CmmDecl)]
- -
-} -}
...@@ -372,7 +371,7 @@ buildSRTs dflags top_srt caf_map ...@@ -372,7 +371,7 @@ buildSRTs dflags top_srt caf_map
instructions for forward refs. --SDM instructions for forward refs. --SDM
-} -}
updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl updInfoSRTs :: LabelMap C_SRT -> CmmDecl -> CmmDecl
updInfoSRTs srt_env (CmmProc top_info top_l live g) = updInfoSRTs srt_env (CmmProc top_info top_l live g) =
CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g
where updInfoTbl l info_tbl where updInfoTbl l info_tbl
......
...@@ -66,7 +66,7 @@ elimCommonBlocks g = replaceLabels env $ copyTicks env g ...@@ -66,7 +66,7 @@ elimCommonBlocks g = replaceLabels env $ copyTicks env g
-- (so avoid comparing them again) -- (so avoid comparing them again)
type DistinctBlocks = [CmmBlock] type DistinctBlocks = [CmmBlock]
type Key = [Label] type Key = [Label]
type Subst = BlockEnv BlockId type Subst = LabelMap BlockId
-- The outer list groups by hash. We retain this grouping throughout. -- The outer list groups by hash. We retain this grouping throughout.
iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
...@@ -186,9 +186,9 @@ dont_care _other = False ...@@ -186,9 +186,9 @@ dont_care _other = False
-- Utilities: equality and substitution on the graph. -- Utilities: equality and substitution on the graph.
-- Given a map ``subst'' from BlockID -> BlockID, we define equality. -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
eqBid :: BlockEnv BlockId -> BlockId -> BlockId -> Bool eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
lookupBid :: BlockEnv BlockId -> BlockId -> BlockId lookupBid :: LabelMap BlockId -> BlockId -> BlockId
lookupBid subst bid = case mapLookup bid subst of lookupBid subst bid = case mapLookup bid subst of
Just bid -> lookupBid subst bid Just bid -> lookupBid subst bid
Nothing -> bid Nothing -> bid
...@@ -266,7 +266,7 @@ eqMaybeWith _ _ _ = False ...@@ -266,7 +266,7 @@ eqMaybeWith _ _ _ = False
-- the same ticks as the respective "source" blocks. This not only -- the same ticks as the respective "source" blocks. This not only
-- means copying ticks, but also adjusting tick scopes where -- means copying ticks, but also adjusting tick scopes where
-- necessary. -- necessary.
copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
copyTicks env g copyTicks env g
| mapNull env = g | mapNull env = g
| otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
......
...@@ -74,7 +74,7 @@ import Prelude hiding (succ, unzip, zip) ...@@ -74,7 +74,7 @@ import Prelude hiding (succ, unzip, zip)
-- Note [Shortcut call returns] -- Note [Shortcut call returns]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- --
-- We are going to maintain the "current" graph (BlockEnv CmmBlock) as -- We are going to maintain the "current" graph (LabelMap CmmBlock) as
-- we go, and also a mapping from BlockId to BlockId, representing -- we go, and also a mapping from BlockId to BlockId, representing
-- continuation labels that we have renamed. This latter mapping is -- continuation labels that we have renamed. This latter mapping is
-- important because we might shortcut a CmmCall continuation. For -- important because we might shortcut a CmmCall continuation. For
...@@ -153,7 +153,7 @@ cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g' ...@@ -153,7 +153,7 @@ cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
cmmCfgOptsProc _ top = top cmmCfgOptsProc _ top = top
blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId) blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
= (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map') = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
where where
...@@ -188,8 +188,8 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } ...@@ -188,8 +188,8 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
initialBackEdges = incPreds entry_id (predMap blocks) initialBackEdges = incPreds entry_id (predMap blocks)
maybe_concat :: CmmBlock maybe_concat :: CmmBlock
-> (BlockEnv CmmBlock, BlockEnv BlockId, BlockEnv Int) -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-> (BlockEnv CmmBlock, BlockEnv BlockId, BlockEnv Int) -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
maybe_concat block (blocks, shortcut_map, backEdges) maybe_concat block (blocks, shortcut_map, backEdges)
-- If: -- If:
-- (1) current block ends with unconditional branch to b' and -- (1) current block ends with unconditional branch to b' and
...@@ -313,7 +313,7 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } ...@@ -313,7 +313,7 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
-- that invariant, but calling replaceLabels may introduce unreachable blocks. -- that invariant, but calling replaceLabels may introduce unreachable blocks.
-- We rely on subsequent passes in the Cmm pipeline to remove unreachable -- We rely on subsequent passes in the Cmm pipeline to remove unreachable
-- blocks. -- blocks.
incPreds, decPreds :: BlockId -> BlockEnv Int -> BlockEnv Int incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int
incPreds bid edges = mapInsertWith (+) bid 1 edges incPreds bid edges = mapInsertWith (+) bid 1 edges
decPreds bid edges = case mapLookup bid edges of decPreds bid edges = case mapLookup bid edges of
Just preds | preds > 1 -> mapInsert bid (preds - 1) edges Just preds | preds > 1 -> mapInsert bid (preds - 1) edges
...@@ -352,8 +352,8 @@ callContinuation_maybe _ = Nothing ...@@ -352,8 +352,8 @@ callContinuation_maybe _ = Nothing
-- Map over the CmmGraph, replacing each label with its mapping in the -- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied BlockEnv. -- supplied LabelMap.
replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels env g replaceLabels env g
| mapNull env = g | mapNull env = g
| otherwise = replace_eid $ mapGraphNodes1 txnode g | otherwise = replace_eid $ mapGraphNodes1 txnode g
...@@ -383,7 +383,7 @@ mkCmmCondBranch p t f l = ...@@ -383,7 +383,7 @@ mkCmmCondBranch p t f l =
if t == f then CmmBranch t else CmmCondBranch p t f l if t == f then CmmBranch t else CmmCondBranch p t f l
-- Build a map from a block to its set of predecessors. -- Build a map from a block to its set of predecessors.
predMap :: [CmmBlock] -> BlockEnv Int predMap :: [CmmBlock] -> LabelMap Int
predMap blocks = foldr add_preds mapEmpty blocks predMap blocks = foldr add_preds mapEmpty blocks
where where
add_preds block env = foldr add env (successors block) add_preds block env = foldr add env (successors block)
...@@ -401,10 +401,10 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g) ...@@ -401,10 +401,10 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
info' = info { info_tbls = keep_used (info_tbls info) } info' = info { info_tbls = keep_used (info_tbls info) }
-- Remove any info_tbls for unreachable -- Remove any info_tbls for unreachable
keep_used :: BlockEnv CmmInfoTable -> BlockEnv CmmInfoTable keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
keep_used bs = mapFoldWithKey keep mapEmpty bs keep_used bs = mapFoldWithKey keep mapEmpty bs
keep :: Label -> CmmInfoTable -> BlockEnv CmmInfoTable -> BlockEnv CmmInfoTable keep :: Label -> CmmInfoTable -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
keep l i env | l `setMember` used_lbls = mapInsert l i env keep l i env | l `setMember` used_lbls = mapInsert l i env
| otherwise = env | otherwise = env
......
...@@ -187,7 +187,7 @@ instance Outputable StackMap where ...@@ -187,7 +187,7 @@ instance Outputable StackMap where
cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
-> UniqSM (CmmGraph, BlockEnv StackMap) -> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack dflags procpoints entry_args cmmLayoutStack dflags procpoints entry_args
graph@(CmmGraph { g_entry = entry }) graph@(CmmGraph { g_entry = entry })
= do = do
...@@ -206,18 +206,18 @@ cmmLayoutStack dflags procpoints entry_args ...@@ -206,18 +206,18 @@ cmmLayoutStack dflags procpoints entry_args
layout :: DynFlags layout :: DynFlags
-> BlockSet -- proc points -> LabelSet -- proc points
-> BlockEnv CmmLocalLive -- liveness -> LabelMap CmmLocalLive -- liveness
-> BlockId -- entry -> BlockId -- entry
-> ByteOff -- stack args on entry -> ByteOff -- stack args on entry
-> BlockEnv StackMap -- [final] stack maps -> LabelMap StackMap -- [final] stack maps
-> ByteOff -- [final] Sp high water mark -> ByteOff -- [final] Sp high water mark
-> [CmmBlock] -- [in] blocks -> [CmmBlock] -- [in] blocks
-> UniqSM -> UniqSM
( BlockEnv StackMap -- [out] stack maps ( LabelMap StackMap -- [out] stack maps
, ByteOff -- [out] Sp high water mark , ByteOff -- [out] Sp high water mark
, [CmmBlock] -- [out] new blocks , [CmmBlock] -- [out] new blocks
) )
...@@ -316,7 +316,7 @@ isGcJump _something_else = False ...@@ -316,7 +316,7 @@ isGcJump _something_else = False
-- unnecessarily pessimistic, but probably not in the code we -- unnecessarily pessimistic, but probably not in the code we
-- generate. -- generate.
collectContInfo :: [CmmBlock] -> (ByteOff, BlockEnv ByteOff) collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)
collectContInfo blocks collectContInfo blocks
= (maximum ret_offs, mapFromList (catMaybes mb_argss)) = (maximum ret_offs, mapFromList (catMaybes mb_argss))
where where
...@@ -344,7 +344,7 @@ collectContInfo blocks ...@@ -344,7 +344,7 @@ collectContInfo blocks
-- on the stack and need to be immediately saved across a call, we -- on the stack and need to be immediately saved across a call, we
-- want to just leave them where they are on the stack. -- want to just leave them where they are on the stack.
-- --
procMiddle :: BlockEnv StackMap -> CmmNode e x -> StackMap -> StackMap procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle stackmaps node sm procMiddle stackmaps node sm
= case node of = case node of
CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _) CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)
...@@ -355,7 +355,7 @@ procMiddle stackmaps node sm ...@@ -355,7 +355,7 @@ procMiddle stackmaps node sm
_other _other
-> sm -> sm
getStackLoc :: Area -> ByteOff -> BlockEnv StackMap -> StackLoc getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
getStackLoc Old n _ = n getStackLoc Old n _ = n
getStackLoc (Young l) n stackmaps = getStackLoc (Young l) n stackmaps =
case mapLookup l stackmaps of case mapLookup l stackmaps of
...@@ -383,8 +383,8 @@ getStackLoc (Young l) n stackmaps = ...@@ -383,8 +383,8 @@ getStackLoc (Young l) n stackmaps =
-- extra code that goes *after* the Sp adjustment. -- extra code that goes *after* the Sp adjustment.
handleLastNode handleLastNode
:: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff
-> BlockEnv StackMap -> StackMap -> CmmTickScope -> LabelMap StackMap -> StackMap -> CmmTickScope
-> Block CmmNode O O -> Block CmmNode O O
-> CmmNode O C -> CmmNode O C
-> UniqSM -> UniqSM
...@@ -392,7 +392,7 @@ handleLastNode ...@@ -392,7 +392,7 @@ handleLastNode
, ByteOff -- amount to adjust Sp , ByteOff -- amount to adjust Sp
, CmmNode O C -- new last node , CmmNode O C -- new last node
, [CmmBlock] -- new blocks , [CmmBlock] -- new blocks
, BlockEnv StackMap -- stackmaps for the continuations , LabelMap StackMap -- stackmaps for the continuations
) )
handleLastNode dflags procpoints liveness cont_info stackmaps handleLastNode dflags procpoints liveness cont_info stackmaps
...@@ -424,7 +424,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps ...@@ -424,7 +424,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
, ByteOff , ByteOff
, CmmNode O C , CmmNode O C
, [CmmBlock] , [CmmBlock]
, BlockEnv StackMap , LabelMap StackMap
) )
lastCall lbl cml_args cml_ret_args cml_ret_off lastCall lbl cml_args cml_ret_args cml_ret_off
= ( assignments = ( assignments
...@@ -457,7 +457,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps ...@@ -457,7 +457,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
, ByteOff , ByteOff
, CmmNode O C , CmmNode O C
, [CmmBlock] , [CmmBlock]
, BlockEnv StackMap ) , LabelMap StackMap )
handleBranches handleBranches
-- Note [diamond proc point] -- Note [diamond proc point]
...@@ -561,7 +561,7 @@ fixupStack old_stack new_stack = concatMap move new_locs ...@@ -561,7 +561,7 @@ fixupStack old_stack new_stack = concatMap move new_locs
setupStackFrame setupStackFrame
:: DynFlags :: DynFlags
-> BlockId -- label of continuation -> BlockId -- label of continuation
-> BlockEnv CmmLocalLive -- liveness -> LabelMap CmmLocalLive -- liveness
-> ByteOff -- updfr -> ByteOff -- updfr
-> ByteOff -- bytes of return values on stack -> ByteOff -- bytes of return values on stack
-> StackMap -- current StackMap -> StackMap -- current StackMap
...@@ -772,7 +772,7 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0 ...@@ -772,7 +772,7 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
-- --
manifestSp manifestSp
:: DynFlags :: DynFlags
-> BlockEnv StackMap -- StackMaps for other blocks -> LabelMap StackMap -- StackMaps for other blocks
-> StackMap -- StackMap for this block -> StackMap -- StackMap for this block
-> ByteOff -- Sp on entry to the block -> ByteOff -- Sp on entry to the block
-> ByteOff -- SpHigh -> ByteOff -- SpHigh
...@@ -813,7 +813,7 @@ manifestSp dflags stackmaps stack0 sp0 sp_high ...@@ -813,7 +813,7 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc) getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)
getAreaOff _ Old = 0 getAreaOff _ Old = 0
getAreaOff stackmaps (Young l) = getAreaOff stackmaps (Young l) =
case mapLookup l stackmaps of case mapLookup l stackmaps of
...@@ -918,7 +918,7 @@ optStackCheck n = -- Note [Always false stack check] ...@@ -918,7 +918,7 @@ optStackCheck n = -- Note [Always false stack check]
-- StackMap will invalidate its mapping there. -- StackMap will invalidate its mapping there.
-- --
elimStackStores :: StackMap elimStackStores :: StackMap
-> BlockEnv StackMap -> LabelMap StackMap
-> (Area -> ByteOff) -> (Area -> ByteOff)
-> [CmmNode O O] -> [CmmNode O O]
-> [CmmNode O O] -> [CmmNode O O]
...@@ -940,7 +940,7 @@ elimStackStores stackmap stackmaps area_off nodes ...@@ -940,7 +940,7 @@ elimStackStores stackmap stackmaps area_off nodes
-- Update info tables to include stack liveness -- Update info tables to include stack liveness
setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g) setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
where where
......
...@@ -16,7 +16,6 @@ import CmmUtils ...@@ -16,7 +16,6 @@ import CmmUtils
import CmmLive import CmmLive
import CmmSwitch (switchTargetsToList) import CmmSwitch (switchTargetsToList)
import PprCmm () import PprCmm ()
import BlockId
import Outputable import Outputable
import DynFlags import DynFlags
...@@ -64,7 +63,7 @@ lintCmmGraph dflags g = ...@@ -64,7 +63,7 @@ lintCmmGraph dflags g =
labels = setFromList (map entryLabel blocks) labels = setFromList (map entryLabel blocks)
lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint () lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
lintCmmBlock labels block lintCmmBlock labels block
= addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
let (_, middle, last) = blockSplit block let (_, middle, last) = blockSplit block
...@@ -157,7 +156,7 @@ lintCmmMiddle node = case node of ...@@ -157,7 +156,7 @@ lintCmmMiddle node = case node of
mapM_ lintCmmExpr actuals mapM_ lintCmmExpr actuals
lintCmmLast :: BlockSet -> CmmNode O C -> CmmLint () lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
lintCmmLast labels node = case node of lintCmmLast labels node = case node of
CmmBranch id -> checkTarget id CmmBranch id -> checkTarget id
......
...@@ -40,7 +40,7 @@ liveLattice = DataflowLattice emptyRegSet add ...@@ -40,7 +40,7 @@ liveLattice = DataflowLattice emptyRegSet add
in changedIf (sizeRegSet join > sizeRegSet old) join in changedIf (sizeRegSet join > sizeRegSet old) join
-- | A mapping from block labels to the variables live on entry -- | A mapping from block labels to the variables live on entry
type BlockEntryLiveness r = BlockEnv (CmmLive r) type BlockEntryLiveness r = LabelMap (CmmLive r)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | Calculated liveness info for a CmmGraph -- | Calculated liveness info for a CmmGraph
......
...@@ -112,7 +112,7 @@ if a proc-point does not exist anymore then we will get compiler panic. ...@@ -112,7 +112,7 @@ if a proc-point does not exist anymore then we will get compiler panic.
See #8205. See #8205.
-} -}
type ProcPointSet = BlockSet type ProcPointSet = LabelSet
data Status data Status
= ReachedBy ProcPointSet -- set of proc points that directly reach the block = ReachedBy ProcPointSet -- set of proc points that directly reach the block
...@@ -131,7 +131,7 @@ instance Outputable Status where ...@@ -131,7 +131,7 @@ instance Outputable Status where
-- Once you know what the proc-points are, figure out -- Once you know what the proc-points are, figure out
-- what proc-points each block is reachable from -- what proc-points each block is reachable from
-- See Note [Proc-point analysis] -- See Note [Proc-point analysis]
procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status) procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (LabelMap Status)
procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) = procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
return $ return $
analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
...@@ -176,7 +176,7 @@ procPointLattice = DataflowLattice unreached add_to ...@@ -176,7 +176,7 @@ procPointLattice = DataflowLattice unreached add_to
-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
callProcPoints :: CmmGraph -> ProcPointSet callProcPoints :: CmmGraph -> ProcPointSet
callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
where add :: CmmBlock -> BlockSet -> BlockSet where add :: CmmBlock -> LabelSet -> LabelSet
add b set = case lastNode b of add b set = case lastNode b of
CmmCall {cml_cont = Just k} -> setInsert k set CmmCall {cml_cont = Just k} -> setInsert k set
CmmForeignCall {succ=k} -> setInsert k set CmmForeignCall {succ=k} -> setInsert k set
...@@ -238,7 +238,7 @@ extendPPSet platform g blocks procPoints = ...@@ -238,7 +238,7 @@ extendPPSet platform g blocks procPoints =
-- Input invariant: A block should only be reachable from a single ProcPoint. -- Input invariant: A block should only be reachable from a single ProcPoint.
-- ToDo: use the _ret naming convention that the old code generator -- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY -- used. -- EZY
splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
CmmDecl -> UniqSM [CmmDecl] CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints dflags entry_label callPPs procPoints procMap splitAtProcPoints dflags entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls}) (CmmProc (TopInfo {info_tbls = info_tbls})
...@@ -388,7 +388,7 @@ splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] ...@@ -388,7 +388,7 @@ splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
-- recursive lookup, see comment below. -- recursive lookup, see comment below.
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceBranches env cmmg replaceBranches env cmmg
= {-# SCC "replaceBranches" #-} = {-# SCC "replaceBranches" #-}
ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
......
...@@ -5,7 +5,6 @@ module CmmSink ( ...@@ -5,7 +5,6 @@ module CmmSink (
import Cmm import Cmm
import CmmOpt import CmmOpt
import BlockId
import CmmLive import CmmLive
import CmmUtils import CmmUtils
import Hoopl import Hoopl
...@@ -154,7 +153,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks ...@@ -154,7 +153,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
join_pts = findJoinPoints blocks join_pts = findJoinPoints blocks
sink :: BlockEnv Assignments -> [CmmBlock] -> [CmmBlock] sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink _ [] = [] sink _ [] = []
sink sunk (b:bs) = sink sunk (b:bs) =
-- pprTrace "sink" (ppr lbl) $ -- pprTrace "sink" (ppr lbl) $
...@@ -253,12 +252,12 @@ annotate dflags live nodes = snd $ foldr ann (live,[]) nodes ...@@ -253,12 +252,12 @@ annotate dflags live nodes = snd $ foldr ann (live,[]) nodes
-- --
-- Find the blocks that have multiple successors (join points) -- Find the blocks that have multiple successors (join points)
-- --
findJoinPoints :: [CmmBlock] -> BlockEnv Int findJoinPoints :: [CmmBlock] -> LabelMap Int
findJoinPoints blocks = mapFilter (>1) succ_counts findJoinPoints blocks = mapFilter (>1) succ_counts
where where
all_succs = concatMap successors blocks all_succs = concatMap successors blocks
succ_counts :: BlockEnv Int succ_counts :: LabelMap Int
succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs
-- --
......
...@@ -476,13 +476,13 @@ mkLiveness dflags (reg:regs) ...@@ -476,13 +476,13 @@ mkLiveness dflags (reg:regs)
modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
toBlockMap :: CmmGraph -> BlockEnv CmmBlock toBlockMap :: CmmGraph -> LabelMap CmmBlock
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body