Commit 23dc6c45 authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

Remove most functions from cmm/BlockId

It seems that `BlockId` module could simply go away in favor
of Hoopl's `Label`. This is the first step to do that.

In a few places I had to add some type signatures, but most of
them seem to help with code readability.
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan: ./validate

Reviewers: austin, simonmar, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2765
parent 758b81d2
...@@ -6,10 +6,9 @@ module BlockId ...@@ -6,10 +6,9 @@ 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 , BlockSet, BlockEnv
, IsSet(..), setInsertList, setDeleteList, setUnions , IsSet(..)
, IsMap(..), mapInsertList, mapDeleteList, mapUnions , IsMap(..)
, emptyBlockSet, emptyBlockMap, lookupBlockMap, insertBlockMap , blockLbl, infoTblLbl
, blockLbl, infoTblLbl, retPtLbl
) where ) where
import CLabel import CLabel
...@@ -48,9 +47,6 @@ mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique ...@@ -48,9 +47,6 @@ mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
newBlockId :: MonadUnique m => m BlockId newBlockId :: MonadUnique m => m BlockId
newBlockId = mkBlockId <$> getUniqueM newBlockId = mkBlockId <$> getUniqueM
retPtLbl :: BlockId -> CLabel
retPtLbl label = mkReturnPtLabel $ getUnique label
blockLbl :: BlockId -> CLabel blockLbl :: BlockId -> CLabel
blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
...@@ -63,20 +59,8 @@ type BlockEnv a = Hoopl.LabelMap a ...@@ -63,20 +59,8 @@ type BlockEnv a = Hoopl.LabelMap a
instance Outputable a => Outputable (BlockEnv a) where instance Outputable a => Outputable (BlockEnv a) where
ppr = ppr . mapToList ppr = ppr . mapToList
emptyBlockMap :: BlockEnv a
emptyBlockMap = mapEmpty
lookupBlockMap :: BlockId -> BlockEnv a -> Maybe a
lookupBlockMap = mapLookup
insertBlockMap :: BlockId -> a -> BlockEnv a -> BlockEnv a
insertBlockMap = mapInsert
-- Block sets -- Block sets
type BlockSet = Hoopl.LabelSet type BlockSet = Hoopl.LabelSet
instance Outputable BlockSet where instance Outputable BlockSet where
ppr = ppr . setElems ppr = ppr . setElems
emptyBlockSet :: BlockSet
emptyBlockSet = setEmpty
...@@ -402,7 +402,7 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g) ...@@ -402,7 +402,7 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
-- Remove any info_tbls for unreachable -- Remove any info_tbls for unreachable
keep_used :: BlockEnv CmmInfoTable -> BlockEnv CmmInfoTable keep_used :: BlockEnv CmmInfoTable -> BlockEnv CmmInfoTable
keep_used bs = mapFoldWithKey keep emptyBlockMap bs keep_used bs = mapFoldWithKey keep mapEmpty bs
keep :: Label -> CmmInfoTable -> BlockEnv CmmInfoTable -> BlockEnv CmmInfoTable keep :: Label -> CmmInfoTable -> BlockEnv CmmInfoTable -> BlockEnv 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
......
...@@ -243,7 +243,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -243,7 +243,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls}) (CmmProc (TopInfo {info_tbls = info_tbls})
top_l _ g@(CmmGraph {g_entry=entry})) = top_l _ g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach do -- Build a map from procpoints to the blocks they reach
let addBlock b graphEnv = let addBlock
:: CmmBlock
-> LabelMap (LabelMap CmmBlock)
-> LabelMap (LabelMap CmmBlock)
addBlock b graphEnv =
case mapLookup bid procMap of case mapLookup bid procMap of
Just ProcPoint -> add graphEnv bid bid b Just ProcPoint -> add graphEnv bid bid b
Just (ReachedBy set) -> Just (ReachedBy set) ->
...@@ -262,7 +266,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -262,7 +266,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
regSetToList $ regSetToList $
expectJust "ppLiveness" $ mapLookup pp liveness expectJust "ppLiveness" $ mapLookup pp liveness
graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g graphEnv <- return $ foldGraphBlocks addBlock mapEmpty g
-- Build a map from proc point BlockId to pairs of: -- Build a map from proc point BlockId to pairs of:
-- * Labels for their new procedures -- * Labels for their new procedures
...@@ -281,13 +285,21 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -281,13 +285,21 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- In each new graph, add blocks jumping off to the new procedures, -- In each new graph, add blocks jumping off to the new procedures,
-- and replace branches to procpoints with branches to the jump-off blocks -- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block (env, bs) (pp, l) = let add_jump_block
:: (LabelMap Label, [CmmBlock])
-> (Label, CLabel)
-> UniqSM (LabelMap Label, [CmmBlock])
add_jump_block (env, bs) (pp, l) =
do bid <- liftM mkBlockId getUniqueM do bid <- liftM mkBlockId getUniqueM
let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
live = ppLiveness pp live = ppLiveness pp
jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
return (mapInsert pp bid env, b : bs) return (mapInsert pp bid env, b : bs)
add_jumps
:: LabelMap CmmGraph
-> (Label, LabelMap CmmBlock)
-> UniqSM (LabelMap CmmGraph)
add_jumps newGraphEnv (ppId, blockEnv) = add_jumps newGraphEnv (ppId, blockEnv) =
do let needed_jumps = -- find which procpoints we currently branch to do let needed_jumps = -- find which procpoints we currently branch to
mapFold add_if_branch_to_pp [] blockEnv mapFold add_if_branch_to_pp [] blockEnv
...@@ -323,7 +335,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -323,7 +335,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- pprTrace "g' pre jumps" (ppr g') $ do -- pprTrace "g' pre jumps" (ppr g') $ do
return (mapInsert ppId g' newGraphEnv) return (mapInsert ppId g' newGraphEnv)
graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
let to_proc (bid, g) let to_proc (bid, g)
| bid == entry | bid == entry
...@@ -360,7 +372,9 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -360,7 +372,9 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- The C back end expects to see return continuations before the -- The C back end expects to see return continuations before the
-- call sites. Here, we sort them in reverse order -- it gets -- call sites. Here, we sort them in reverse order -- it gets
-- reversed later. -- reversed later.
let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g) let (_, block_order) =
foldl add_block_num (0::Int, mapEmpty :: LabelMap Int)
(postorderDfs g)
add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map) add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
sort_fn (bid, _) (bid', _) = sort_fn (bid, _) (bid', _) =
compare (expectJust "block_order" $ mapLookup bid block_order) compare (expectJust "block_order" $ mapLookup bid block_order)
......
...@@ -877,7 +877,8 @@ build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks))) ...@@ -877,7 +877,8 @@ build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
-- find all the blocks that just consist of a jump that can be -- find all the blocks that just consist of a jump that can be
-- shorted. -- shorted.
-- Don't completely eliminate loops here -- that can leave a dangling jump! -- Don't completely eliminate loops here -- that can leave a dangling jump!
(_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks (_, shortcut_blocks, others) =
foldl split (setEmpty :: LabelSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
| Just jd <- canShortcut ncgImpl insn, | Just jd <- canShortcut ncgImpl insn,
Just dest <- getJumpDestBlockId ncgImpl jd, Just dest <- getJumpDestBlockId ncgImpl jd,
......
...@@ -135,7 +135,7 @@ regSpill_top platform regSlotMap cmm ...@@ -135,7 +135,7 @@ regSpill_top platform regSlotMap cmm
= let = let
-- Slots that are already recorded as being live. -- Slots that are already recorded as being live.
curSlotsLive = fromMaybe IntSet.empty curSlotsLive = fromMaybe IntSet.empty
$ lookupBlockMap blockId slotMap $ mapLookup blockId slotMap
moreSlotsLive = IntSet.fromList moreSlotsLive = IntSet.fromList
$ catMaybes $ catMaybes
...@@ -144,8 +144,8 @@ regSpill_top platform regSlotMap cmm ...@@ -144,8 +144,8 @@ regSpill_top platform regSlotMap cmm
-- See Note [Unique Determinism and code generation] -- See Note [Unique Determinism and code generation]
slotMap' slotMap'
= insertBlockMap blockId (IntSet.union curSlotsLive moreSlotsLive) = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)
slotMap slotMap
in slotMap' in slotMap'
......
...@@ -381,7 +381,7 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs) ...@@ -381,7 +381,7 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
let slotsReloadedByTargets let slotsReloadedByTargets
= IntSet.unions = IntSet.unions
$ catMaybes $ catMaybes
$ map (flip lookupBlockMap liveSlotsOnEntry) $ map (flip mapLookup liveSlotsOnEntry)
$ targets $ targets
let noReloads' let noReloads'
......
...@@ -234,7 +234,7 @@ linearRegAlloc' ...@@ -234,7 +234,7 @@ linearRegAlloc'
linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs
= do us <- getUniqueSupplyM = do us <- getUniqueSupplyM
let (_, stack, stats, blocks) = let (_, stack, stats, blocks) =
runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us
$ linearRA_SCCs entry_ids block_live [] sccs $ linearRA_SCCs entry_ids block_live [] sccs
return (blocks, stats, getStackUse stack) return (blocks, stats, getStackUse stack)
......
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
module RegAlloc.Liveness ( module RegAlloc.Liveness (
RegSet, RegSet,
RegMap, emptyRegMap, RegMap, emptyRegMap,
BlockMap, emptyBlockMap, BlockMap, mapEmpty,
LiveCmmDecl, LiveCmmDecl,
InstrSR (..), InstrSR (..),
LiveInstr (..), LiveInstr (..),
...@@ -646,7 +646,7 @@ natCmmTopToLive (CmmData i d) ...@@ -646,7 +646,7 @@ natCmmTopToLive (CmmData i d)
= CmmData i d = CmmData i d
natCmmTopToLive (CmmProc info lbl live (ListGraph [])) natCmmTopToLive (CmmProc info lbl live (ListGraph []))
= CmmProc (LiveInfo info [] Nothing emptyBlockMap) lbl live [] = CmmProc (LiveInfo info [] Nothing mapEmpty) lbl live []
natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
= let first_id = blockId first = let first_id = blockId first
...@@ -657,7 +657,7 @@ natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) ...@@ -657,7 +657,7 @@ natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
$ sccs $ sccs
in CmmProc (LiveInfo info (first_id : entry_ids) Nothing emptyBlockMap) in CmmProc (LiveInfo info (first_id : entry_ids) Nothing mapEmpty)
lbl live sccsLive lbl live sccsLive
...@@ -723,7 +723,7 @@ regLiveness _ (CmmData i d) ...@@ -723,7 +723,7 @@ regLiveness _ (CmmData i d)
regLiveness _ (CmmProc info lbl live []) regLiveness _ (CmmProc info lbl live [])
| LiveInfo static mFirst _ _ <- info | LiveInfo static mFirst _ _ <- info
= return $ CmmProc = return $ CmmProc
(LiveInfo static mFirst (Just mapEmpty) emptyBlockMap) (LiveInfo static mFirst (Just mapEmpty) mapEmpty)
lbl live [] lbl live []
regLiveness platform (CmmProc info lbl live sccs) regLiveness platform (CmmProc info lbl live sccs)
...@@ -805,7 +805,7 @@ computeLiveness ...@@ -805,7 +805,7 @@ computeLiveness
computeLiveness platform sccs computeLiveness platform sccs
= case checkIsReverseDependent sccs of = case checkIsReverseDependent sccs of
Nothing -> livenessSCCs platform emptyBlockMap [] sccs Nothing -> livenessSCCs platform mapEmpty [] sccs
Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss"
(vcat [ text "SCCs aren't in reverse dependent order" (vcat [ text "SCCs aren't in reverse dependent order"
, text "bad blockId" <+> ppr bad , text "bad blockId" <+> ppr bad
......
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