summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/BlockId.hs22
-rw-r--r--compiler/cmm/CmmContFlowOpt.hs2
-rw-r--r--compiler/cmm/CmmProcPoint.hs24
-rw-r--r--compiler/nativeGen/AsmCodeGen.hs3
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Spill.hs6
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/SpillClean.hs2
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Main.hs2
-rw-r--r--compiler/nativeGen/RegAlloc/Liveness.hs10
8 files changed, 35 insertions, 36 deletions
diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
index f54beeca9f..9e96b979b4 100644
--- a/compiler/cmm/BlockId.hs
+++ b/compiler/cmm/BlockId.hs
@@ -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
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index ed953ac5a8..b825f86275 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -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
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 9459a1058c..0efd45c104 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -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)
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index affb3e4e4a..ad897abc0f 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -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,
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index a9ea6e5728..445f416187 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -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,8 +144,8 @@ regSpill_top platform regSlotMap cmm
-- See Note [Unique Determinism and code generation]
slotMap'
- = insertBlockMap blockId (IntSet.union curSlotsLive moreSlotsLive)
- slotMap
+ = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)
+ slotMap
in slotMap'
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index 1df4b2570a..c75bcebb7b 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -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'
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 0fe2592e60..cec08a2f3f 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -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)
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 988bda05a8..98b9659748 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -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
View Lorry Controller Status