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