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 @@
module BlockId
( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
, newBlockId
, BlockSet, BlockEnv
, IsSet(..)
, IsMap(..)
, blockLbl, infoTblLbl
) where
......@@ -52,15 +49,3 @@ blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
infoTblLbl :: BlockId -> CLabel
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]
type GenCmmGroup d h g = [GenCmmDecl d h g]
type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) CmmGraph
type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph
-----------------------------------------------------------------------------
-- CmmDecl, GenCmmDecl
......@@ -94,7 +94,7 @@ type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
type RawCmmDecl
= GenCmmDecl
CmmStatics
(BlockEnv CmmStatics)
(LabelMap CmmStatics)
CmmGraph
-----------------------------------------------------------------------------
......@@ -114,7 +114,7 @@ type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f
-- Info Tables
-----------------------------------------------------------------------------
data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable
data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable
, stack_info :: CmmStackInfo }
topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
......
......@@ -9,7 +9,6 @@ where
import Hoopl
import Digraph
import BlockId
import Bitmap
import CLabel
import PprCmmDecl ()
......@@ -83,7 +82,7 @@ This is what flattenCAFSets is doing.
-- Finding the CAFs used by a procedure
type CAFSet = Set CLabel
type CAFEnv = BlockEnv CAFSet
type CAFEnv = LabelMap CAFSet
cafLattice :: DataflowLattice CAFSet
cafLattice = DataflowLattice Set.empty add
......@@ -292,7 +291,7 @@ flatten env cafset = foldSet (lookup env) Set.empty cafset
bundle :: Map CLabel CAFSet
-> (CAFEnv, CmmDecl)
-> (CAFSet, Maybe CLabel)
-> (BlockEnv CAFSet, CmmDecl)
-> (LabelMap CAFSet, CmmDecl)
bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl)
= ( mapMapWithKey get_cafs (info_tbls infos), decl )
where
......@@ -316,7 +315,7 @@ bundle _flatmap (_, decl) _
= ( mapEmpty, decl )
flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(BlockEnv CAFSet, CmmDecl)]
flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(LabelMap CAFSet, CmmDecl)]
flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
where
zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
......@@ -342,8 +341,8 @@ doSRTs dflags topSRT tops
setSRT (topSRT, rst) (_, decl) =
return (topSRT, decl : rst)
buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet
-> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT)
buildSRTs :: DynFlags -> TopSRT -> LabelMap CAFSet
-> UniqSM (TopSRT, [CmmDecl], LabelMap C_SRT)
buildSRTs dflags top_srt caf_map
= foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
where
......@@ -359,7 +358,7 @@ buildSRTs dflags top_srt caf_map
- Each one needs an SRT.
- We get the CAFSet for each one from the CAFEnv
- flatten gives us
[(BlockEnv CAFSet, CmmDecl)]
[(LabelMap CAFSet, CmmDecl)]
-
-}
......@@ -372,7 +371,7 @@ buildSRTs dflags top_srt caf_map
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) =
CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g
where updInfoTbl l info_tbl
......
......@@ -66,7 +66,7 @@ elimCommonBlocks g = replaceLabels env $ copyTicks env g
-- (so avoid comparing them again)
type DistinctBlocks = [CmmBlock]
type Key = [Label]
type Subst = BlockEnv BlockId
type Subst = LabelMap BlockId
-- The outer list groups by hash. We retain this grouping throughout.
iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
......@@ -186,9 +186,9 @@ dont_care _other = False
-- Utilities: equality and substitution on the graph.
-- 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'
lookupBid :: BlockEnv BlockId -> BlockId -> BlockId
lookupBid :: LabelMap BlockId -> BlockId -> BlockId
lookupBid subst bid = case mapLookup bid subst of
Just bid -> lookupBid subst bid
Nothing -> bid
......@@ -266,7 +266,7 @@ eqMaybeWith _ _ _ = False
-- the same ticks as the respective "source" blocks. This not only
-- means copying ticks, but also adjusting tick scopes where
-- necessary.
copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph
copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
copyTicks env g
| mapNull env = g
| otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
......
......@@ -74,7 +74,7 @@ import Prelude hiding (succ, unzip, zip)
-- 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
-- continuation labels that we have renamed. This latter mapping is
-- 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'
cmmCfgOptsProc _ top = top
blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId)
blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
= (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
where
......@@ -188,8 +188,8 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
initialBackEdges = incPreds entry_id (predMap blocks)
maybe_concat :: CmmBlock
-> (BlockEnv CmmBlock, BlockEnv BlockId, BlockEnv Int)
-> (BlockEnv CmmBlock, BlockEnv BlockId, BlockEnv Int)
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
maybe_concat block (blocks, shortcut_map, backEdges)
-- If:
-- (1) current block ends with unconditional branch to b' and
......@@ -313,7 +313,7 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
-- that invariant, but calling replaceLabels may introduce unreachable blocks.
-- We rely on subsequent passes in the Cmm pipeline to remove unreachable
-- blocks.
incPreds, decPreds :: BlockId -> BlockEnv Int -> BlockEnv Int
incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int
incPreds bid edges = mapInsertWith (+) bid 1 edges
decPreds bid edges = case mapLookup bid edges of
Just preds | preds > 1 -> mapInsert bid (preds - 1) edges
......@@ -352,8 +352,8 @@ callContinuation_maybe _ = Nothing
-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied BlockEnv.
replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
-- supplied LabelMap.
replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels env g
| mapNull env = g
| otherwise = replace_eid $ mapGraphNodes1 txnode g
......@@ -383,7 +383,7 @@ mkCmmCondBranch 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.
predMap :: [CmmBlock] -> BlockEnv Int
predMap :: [CmmBlock] -> LabelMap Int
predMap blocks = foldr add_preds mapEmpty blocks
where
add_preds block env = foldr add env (successors block)
......@@ -401,10 +401,10 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
info' = info { info_tbls = keep_used (info_tbls info) }
-- 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 :: 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
| otherwise = env
......
......@@ -187,7 +187,7 @@ instance Outputable StackMap where
cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
-> UniqSM (CmmGraph, BlockEnv StackMap)
-> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack dflags procpoints entry_args
graph@(CmmGraph { g_entry = entry })
= do
......@@ -206,18 +206,18 @@ cmmLayoutStack dflags procpoints entry_args
layout :: DynFlags
-> BlockSet -- proc points
-> BlockEnv CmmLocalLive -- liveness
-> LabelSet -- proc points
-> LabelMap CmmLocalLive -- liveness
-> BlockId -- entry
-> ByteOff -- stack args on entry
-> BlockEnv StackMap -- [final] stack maps
-> LabelMap StackMap -- [final] stack maps
-> ByteOff -- [final] Sp high water mark
-> [CmmBlock] -- [in] blocks
-> UniqSM
( BlockEnv StackMap -- [out] stack maps
( LabelMap StackMap -- [out] stack maps
, ByteOff -- [out] Sp high water mark
, [CmmBlock] -- [out] new blocks
)
......@@ -316,7 +316,7 @@ isGcJump _something_else = False
-- unnecessarily pessimistic, but probably not in the code we
-- generate.
collectContInfo :: [CmmBlock] -> (ByteOff, BlockEnv ByteOff)
collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)
collectContInfo blocks
= (maximum ret_offs, mapFromList (catMaybes mb_argss))
where
......@@ -344,7 +344,7 @@ collectContInfo blocks
-- on the stack and need to be immediately saved across a call, we
-- 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
= case node of
CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)
......@@ -355,7 +355,7 @@ procMiddle stackmaps node sm
_other
-> sm
getStackLoc :: Area -> ByteOff -> BlockEnv StackMap -> StackLoc
getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
getStackLoc Old n _ = n
getStackLoc (Young l) n stackmaps =
case mapLookup l stackmaps of
......@@ -383,8 +383,8 @@ getStackLoc (Young l) n stackmaps =
-- extra code that goes *after* the Sp adjustment.
handleLastNode
:: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
-> BlockEnv StackMap -> StackMap -> CmmTickScope
:: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff
-> LabelMap StackMap -> StackMap -> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
......@@ -392,7 +392,7 @@ handleLastNode
, ByteOff -- amount to adjust Sp
, CmmNode O C -- new last node
, [CmmBlock] -- new blocks
, BlockEnv StackMap -- stackmaps for the continuations
, LabelMap StackMap -- stackmaps for the continuations
)
handleLastNode dflags procpoints liveness cont_info stackmaps
......@@ -424,7 +424,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
, ByteOff
, CmmNode O C
, [CmmBlock]
, BlockEnv StackMap
, LabelMap StackMap
)
lastCall lbl cml_args cml_ret_args cml_ret_off
= ( assignments
......@@ -457,7 +457,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
, ByteOff
, CmmNode O C
, [CmmBlock]
, BlockEnv StackMap )
, LabelMap StackMap )
handleBranches
-- Note [diamond proc point]
......@@ -561,7 +561,7 @@ fixupStack old_stack new_stack = concatMap move new_locs
setupStackFrame
:: DynFlags
-> BlockId -- label of continuation
-> BlockEnv CmmLocalLive -- liveness
-> LabelMap CmmLocalLive -- liveness
-> ByteOff -- updfr
-> ByteOff -- bytes of return values on stack
-> StackMap -- current StackMap
......@@ -772,7 +772,7 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
--
manifestSp
:: DynFlags
-> BlockEnv StackMap -- StackMaps for other blocks
-> LabelMap StackMap -- StackMaps for other blocks
-> StackMap -- StackMap for this block
-> ByteOff -- Sp on entry to the block
-> ByteOff -- SpHigh
......@@ -813,7 +813,7 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
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 stackmaps (Young l) =
case mapLookup l stackmaps of
......@@ -918,7 +918,7 @@ optStackCheck n = -- Note [Always false stack check]
-- StackMap will invalidate its mapping there.
--
elimStackStores :: StackMap
-> BlockEnv StackMap
-> LabelMap StackMap
-> (Area -> ByteOff)
-> [CmmNode O O]
-> [CmmNode O O]
......@@ -940,7 +940,7 @@ elimStackStores stackmap stackmaps area_off nodes
-- 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)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
where
......
......@@ -16,7 +16,6 @@ import CmmUtils
import CmmLive
import CmmSwitch (switchTargetsToList)
import PprCmm ()
import BlockId
import Outputable
import DynFlags
......@@ -64,7 +63,7 @@ lintCmmGraph dflags g =
labels = setFromList (map entryLabel blocks)
lintCmmBlock :: BlockSet -> CmmBlock -> CmmLint ()
lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
lintCmmBlock labels block
= addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
let (_, middle, last) = blockSplit block
......@@ -157,7 +156,7 @@ lintCmmMiddle node = case node of
mapM_ lintCmmExpr actuals
lintCmmLast :: BlockSet -> CmmNode O C -> CmmLint ()
lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
lintCmmLast labels node = case node of
CmmBranch id -> checkTarget id
......
......@@ -40,7 +40,7 @@ liveLattice = DataflowLattice emptyRegSet add
in changedIf (sizeRegSet join > sizeRegSet old) join
-- | 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
......
......@@ -112,7 +112,7 @@ if a proc-point does not exist anymore then we will get compiler panic.
See #8205.
-}
type ProcPointSet = BlockSet
type ProcPointSet = LabelSet
data Status
= ReachedBy ProcPointSet -- set of proc points that directly reach the block
......@@ -131,7 +131,7 @@ instance Outputable Status where
-- Once you know what the proc-points are, figure out
-- what proc-points each block is reachable from
-- See Note [Proc-point analysis]
procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status)
procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (LabelMap Status)
procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
return $
analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
......@@ -176,7 +176,7 @@ procPointLattice = DataflowLattice unreached add_to
-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
callProcPoints :: CmmGraph -> ProcPointSet
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
CmmCall {cml_cont = Just k} -> setInsert k set
CmmForeignCall {succ=k} -> setInsert k set
......@@ -238,7 +238,7 @@ extendPPSet platform g blocks procPoints =
-- Input invariant: A block should only be reachable from a single ProcPoint.
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints dflags entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls})
......@@ -388,7 +388,7 @@ splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
-- recursive lookup, see comment below.
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceBranches env cmmg
= {-# SCC "replaceBranches" #-}
ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
......
......@@ -5,7 +5,6 @@ module CmmSink (
import Cmm
import CmmOpt
import BlockId
import CmmLive
import CmmUtils
import Hoopl
......@@ -154,7 +153,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
join_pts = findJoinPoints blocks
sink :: BlockEnv Assignments -> [CmmBlock] -> [CmmBlock]
sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink _ [] = []
sink sunk (b:bs) =
-- pprTrace "sink" (ppr lbl) $
......@@ -253,12 +252,12 @@ annotate dflags live nodes = snd $ foldr ann (live,[]) nodes
--
-- Find the blocks that have multiple successors (join points)
--
findJoinPoints :: [CmmBlock] -> BlockEnv Int
findJoinPoints :: [CmmBlock] -> LabelMap Int
findJoinPoints blocks = mapFilter (>1) succ_counts
where
all_succs = concatMap successors blocks
succ_counts :: BlockEnv Int
succ_counts :: LabelMap Int
succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs
--
......
......@@ -476,13 +476,13 @@ mkLiveness dflags (reg:regs)
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)}
toBlockMap :: CmmGraph -> BlockEnv CmmBlock
toBlockMap :: CmmGraph -> LabelMap CmmBlock
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
ofBlockMap :: BlockId -> BlockEnv CmmBlock -> CmmGraph
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
insertBlock :: CmmBlock -> BlockEnv CmmBlock -> BlockEnv CmmBlock
insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
insertBlock block map =
ASSERT(isNothing $ mapLookup id map)
mapInsert id block map
......
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hoopl (
module Compiler.Hoopl,
......@@ -19,3 +20,10 @@ import Compiler.Hoopl hiding
)
import Hoopl.Dataflow
import Outputable
instance Outputable LabelSet where
ppr = ppr . setElems
instance Outputable a => Outputable (LabelMap a) where
ppr = ppr . mapToList
......@@ -30,7 +30,6 @@ module Hoopl.Dataflow
)
where
import BlockId
import Cmm
import Data.Array
......
......@@ -162,7 +162,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr),
ncgMakeFarBranches :: BlockEnv CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr]
ncgMakeFarBranches :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr]
}
--------------------
......@@ -761,7 +761,7 @@ sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) =
sequenceBlocks
:: Instruction instr
=> BlockEnv i
=> LabelMap i
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
......@@ -796,7 +796,7 @@ mkNode :: (Instruction t)
-> (GenBasicBlock t, BlockId, [BlockId])
mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
seqBlocks :: BlockEnv i -> [(GenBasicBlock t1, BlockId, [BlockId])]
seqBlocks :: LabelMap i -> [(GenBasicBlock t1, BlockId, [BlockId])]
-> [GenBasicBlock t1]
seqBlocks infos blocks = placeNext pullable0 todo0
where
......@@ -864,8 +864,8 @@ shortcutBranches dflags ncgImpl tops
mapping = foldr plusUFM emptyUFM mappings
build_mapping :: NcgImpl statics instr jumpDest
-> GenCmmDecl d (BlockEnv t) (ListGraph instr)
-> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest)
-> GenCmmDecl d (LabelMap t) (ListGraph instr)
-> (GenCmmDecl d (LabelMap t) (ListGraph instr), UniqFM jumpDest)
build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
build_mapping _ (CmmProc info lbl live (ListGraph []))
= (CmmProc info lbl live (ListGraph []), emptyUFM)
......
......@@ -17,6 +17,7 @@ where
import Reg
import BlockId
import Hoopl
import DynFlags
import Cmm hiding (topInfoTable)
import Platform
......@@ -43,13 +44,13 @@ noUsage = RU [] []
type NatCmm instr
= GenCmmGroup
CmmStatics
(BlockEnv CmmStatics)
(LabelMap CmmStatics)
(ListGraph instr)
type NatCmmDecl statics instr
= GenCmmDecl
statics
(BlockEnv CmmStatics)
(LabelMap CmmStatics)
(ListGraph instr)
......@@ -59,7 +60,7 @@ type NatBasicBlock instr
-- | Returns the info table associated with the CmmDecl's entry point,
-- if any.
topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i
topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i
topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
= mapLookup (blockId b) infos
topInfoTable _
......@@ -67,7 +68,7 @@ topInfoTable _
-- | Return the list of BlockIds in a CmmDecl that are entry points
-- for this proc (i.e. they may be jumped to from outside this proc).
entryBlocks :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> [BlockId]
entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]
entryBlocks (CmmProc info _ _ (ListGraph code)) = entries
where
infos = mapKeys info
......
......@@ -42,6 +42,7 @@ import Format
import TargetReg
import BlockId
import Hoopl
import CLabel ( CLabel, mkAsmTempLabel )
import Debug
import FastString ( FastString )
......
......@@ -33,6 +33,7 @@ import Reg
import CodeGen.Platform
import BlockId
import Hoopl
import DynFlags
import Cmm
import CmmInfo
......@@ -117,7 +118,7 @@ allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
alloc = mkStackAllocInstr platform delta
dealloc = mkStackDeallocInstr platform delta
new_blockmap :: BlockEnv BlockId
new_blockmap :: LabelMap BlockId
new_blockmap = mapFromList (zip entries (map mkBlockId uniqs))
insert_stack_insns (BasicBlock id insns)
......@@ -655,7 +656,7 @@ ppc_takeRegRegMoveInstr _ = Nothing
-- big, we have to work around this limitation.
makeFarBranches
:: BlockEnv CmmStatics
:: LabelMap CmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
makeFarBranches info_env blocks
......
......@@ -20,7 +20,7 @@ import RegClass
import TargetReg
import Cmm hiding (topInfoTable)
import BlockId
import Hoopl
import CLabel
......@@ -104,7 +104,7 @@ pprFunctionPrologue lab = pprGloblDecl lab
$$ text "\t.localentry\t" <> ppr lab
<> text ",.-" <> ppr lab
pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc
pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
pprBasicBlock info_env (BasicBlock blockid instrs)
= maybe_infotable $$
pprLabel (mkAsmTempLabel (getUnique blockid)) $$
......