[Git][ghc/ghc][wip/romes/12935] More explicit
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri Jul 12 10:53:15 UTC 2024
Matthew Pickering pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
fef3e436 by Matthew Pickering at 2024-07-12T11:52:35+01:00
More explicit
- - - - -
23 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/BlockId.hs
- compiler/GHC/Cmm/CommonBlockElim.hs
- compiler/GHC/Cmm/ContFlowOpt.hs
- compiler/GHC/Cmm/Dataflow/Graph.hs
- compiler/GHC/Cmm/Dataflow/Label/NonDet.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/Cmm/Dominators.hs
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/LayoutStack.hs
- compiler/GHC/Cmm/Node.hs
- compiler/GHC/Cmm/ProcPoint.hs
- compiler/GHC/Cmm/Reducibility.hs
- compiler/GHC/Cmm/UniqueRenamer.hs
- compiler/GHC/Cmm/Utils.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/CFG.hs
- compiler/GHC/CmmToAsm/Monad.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -51,7 +51,7 @@ import GHC.Runtime.Heap.Layout
import GHC.Cmm.Expr
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
import GHC.Utils.Outputable
import Data.Void (Void)
@@ -79,7 +79,7 @@ type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
-- | Cmm group with SRTs
type CmmGroupSRTs = GenCmmGroup RawCmmStatics CmmTopInfo CmmGraph
-- | "Raw" cmm group (TODO (osa): not sure what that means)
-type RawCmmGroup = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
+type RawCmmGroup = GenCmmGroup RawCmmStatics (Det.LabelMap RawCmmStatics) CmmGraph
-----------------------------------------------------------------------------
-- CmmDecl, GenCmmDecl
@@ -131,7 +131,7 @@ cmmDataDeclCmmDecl = \ case
type RawCmmDecl
= GenCmmDecl
RawCmmStatics
- (LabelMap RawCmmStatics)
+ (Det.LabelMap RawCmmStatics)
CmmGraph
-----------------------------------------------------------------------------
@@ -145,7 +145,7 @@ type CmmBlock = Block CmmNode C C
instance OutputableP Platform CmmGraph where
pdoc = pprCmmGraph
-toBlockMap :: CmmGraph -> LabelMap CmmBlock
+toBlockMap :: CmmGraph -> Det.LabelMap CmmBlock
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
pprCmmGraph :: Platform -> CmmGraph -> SDoc
@@ -163,7 +163,7 @@ revPostorder g = {-# SCC "revPostorder" #-}
revPostorderFrom (toBlockMap g) (g_entry g)
toBlockList :: CmmGraph -> [CmmBlock]
-toBlockList g = mapElems $ toBlockMap g
+toBlockList g = Det.mapElems $ toBlockMap g
-----------------------------------------------------------------------------
-- Info Tables
@@ -171,7 +171,7 @@ toBlockList g = mapElems $ toBlockMap g
-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains
-- the extra info (beyond the executable code) that belongs to that CmmDecl.
-data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable
+data CmmTopInfo = TopInfo { info_tbls :: Det.LabelMap CmmInfoTable
, stack_info :: CmmStackInfo }
instance OutputableP Platform CmmTopInfo where
@@ -183,7 +183,7 @@ pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
text "stack_info: " <> ppr stack_info]
topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
-topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
+topInfoTable (CmmProc infos _ _ g) = Det.mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing
data CmmStackInfo
=====================================
compiler/GHC/Cmm/BlockId.hs
=====================================
@@ -17,7 +17,7 @@ import GHC.Types.Name
import GHC.Types.Unique
import qualified GHC.Types.Unique.DSM as DSM
-import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel)
+import qualified GHC.Cmm.Dataflow.Label as Det (Label, mkHooplLabel)
----------------------------------------------------------------
--- Block Ids, their environments, and their sets
@@ -31,10 +31,10 @@ most assembly languages allow, a label is visible throughout the entire
compilation unit in which it appears.
-}
-type BlockId = Label
+type BlockId = Det.Label
mkBlockId :: Unique -> BlockId
-mkBlockId unique = mkHooplLabel $ getKey unique
+mkBlockId unique = Det.mkHooplLabel $ getKey unique
-- If the monad unique instance uses a deterministic unique supply, this will
-- give you a deterministic unique. Otherwise, it will not. Note that from Cmm
=====================================
compiler/GHC/Cmm/CommonBlockElim.hs
=====================================
@@ -16,7 +16,8 @@ import GHC.Cmm.ContFlowOpt
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import Data.Functor.Classes (liftEq)
import Data.Maybe (mapMaybe)
import qualified Data.List as List
@@ -62,7 +63,7 @@ import qualified Data.List.NonEmpty as NE
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g = replaceLabels env $ copyTicks env g
where
- env = iterate mapEmpty blocks_with_key
+ env = iterate NonDet.mapEmpty blocks_with_key
-- The order of blocks doesn't matter here. While we could use
-- revPostorder which drops unreachable blocks this is done in
-- ContFlowOpt already which runs before this pass. So we use
@@ -73,26 +74,26 @@ elimCommonBlocks g = replaceLabels env $ copyTicks env g
-- Invariant: The blocks in the list are pairwise distinct
-- (so avoid comparing them again)
type DistinctBlocks = [CmmBlock]
-type Key = [Label]
-type Subst = LabelMap BlockId
+type Key = [NonDet.Label]
+type Subst = NonDet.LabelMap BlockId
-- The outer list groups by hash. We retain this grouping throughout.
iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
iterate subst blocks
- | mapNull new_substs = subst
+ | NonDet.mapNull new_substs = subst
| otherwise = iterate subst' updated_blocks
where
grouped_blocks :: [[(Key, NonEmpty DistinctBlocks)]]
grouped_blocks = map groupByLabel blocks
merged_blocks :: [[(Key, DistinctBlocks)]]
- (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
+ (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) NonDet.mapEmpty grouped_blocks
where
- go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
+ go !new_subst1 (k,dbs) = (new_subst1 `NonDet.mapUnion` new_subst2, (k,db))
where
(new_subst2, db) = mergeBlockList subst dbs
- subst' = subst `mapUnion` new_substs
+ subst' = subst `NonDet.mapUnion` new_substs
updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
-- Combine two lists of blocks.
@@ -100,21 +101,21 @@ iterate subst blocks
mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
mergeBlocks subst existing new = go new
where
- go [] = (mapEmpty, existing)
+ go [] = (NonDet.mapEmpty, existing)
go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
-- This block is a duplicate. Drop it, and add it to the substitution
- Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
+ Just b' -> first (NonDet.mapInsert (entryLabel b) (entryLabel b')) $ go bs
-- This block is not a duplicate, keep it.
Nothing -> second (b:) $ go bs
mergeBlockList :: Subst -> NonEmpty DistinctBlocks -> (Subst, DistinctBlocks)
-mergeBlockList subst (b:|bs) = go mapEmpty b bs
+mergeBlockList subst (b:|bs) = go NonDet.mapEmpty b bs
where
go !new_subst1 b [] = (new_subst1, b)
go !new_subst1 b1 (b2:bs) = go new_subst b bs
where
(new_subst2, b) = mergeBlocks subst b1 b2
- new_subst = new_subst1 `mapUnion` new_subst2
+ new_subst = new_subst1 `NonDet.mapUnion` new_subst2
-- -----------------------------------------------------------------------------
@@ -197,10 +198,10 @@ dont_care _other = False
-- Utilities: equality and substitution on the graph.
-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
-eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
+eqBid :: NonDet.LabelMap BlockId -> BlockId -> BlockId -> Bool
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
-lookupBid :: LabelMap BlockId -> BlockId -> BlockId
-lookupBid subst bid = case mapLookup bid subst of
+lookupBid :: NonDet.LabelMap BlockId -> BlockId -> BlockId
+lookupBid subst bid = case NonDet.mapLookup bid subst of
Just bid -> lookupBid subst bid
Nothing -> bid
@@ -270,18 +271,18 @@ eqLastWith _ _ _ = False
-- the same ticks as the respective "source" blocks. This not only
-- means copying ticks, but also adjusting tick scopes where
-- necessary.
-copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
+copyTicks :: NonDet.LabelMap BlockId -> CmmGraph -> CmmGraph
copyTicks env g
- | mapNull env = g
- | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
+ | NonDet.mapNull env = g
+ | otherwise = ofBlockMap (g_entry g) $ Det.mapMap copyTo blockMap
where -- Reverse block merge map
blockMap = toBlockMap g
- revEnv = mapFoldlWithKey insertRev M.empty env
+ revEnv = NonDet.nonDetMapFoldlWithKey insertRev M.empty env
insertRev m k x = M.insertWith (const (k:)) x [k] m
-- Copy ticks and scopes into the given block
copyTo block = case M.lookup (entryLabel block) revEnv of
Nothing -> block
- Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
+ Just ls -> foldr copy block $ mapMaybe (flip Det.mapLookup blockMap) ls
copy from to =
let ticks = blockTicks from
CmmEntry _ scp0 = firstNode from
@@ -293,7 +294,7 @@ copyTicks env g
-- See Note [Compressed TrieMap] in GHC.Core.Map.Expr about the usage of GenMap.
groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, NonEmpty DistinctBlocks)]
groupByLabel =
- go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, NonEmpty DistinctBlocks))
+ go (TM.emptyTM :: TM.ListMap (TM.GenMap NonDet.LabelMap) (Key, NonEmpty DistinctBlocks))
where
go !m [] = TM.foldTM (:) m []
go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries
=====================================
compiler/GHC/Cmm/ContFlowOpt.hs
=====================================
@@ -11,7 +11,8 @@ import GHC.Prelude hiding (succ, unzip, zip)
import GHC.Cmm.Dataflow.Block hiding (blockConcat)
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
@@ -139,13 +140,13 @@ cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
where (g', env) = blockConcat split g
info' = info{ info_tbls = new_info_tbls }
- new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
+ new_info_tbls = Det.mapFromList (map upd_info (Det.mapToList (info_tbls info)))
-- If we changed any labels, then we have to update the info tables
-- too, except for the top-level info table because that might be
-- referred to by other procs.
upd_info (k,info)
- | Just k' <- mapLookup k env
+ | Just k' <- NonDet.mapLookup k env
= (k', if k' == g_entry g'
then info
else info{ cit_lbl = infoTblLbl k' })
@@ -154,7 +155,7 @@ cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
cmmCfgOptsProc _ top = top
-blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
+blockConcat :: Bool -> CmmGraph -> (CmmGraph, NonDet.LabelMap BlockId)
blockConcat splitting_procs g at CmmGraph { g_entry = entry_id }
= (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
where
@@ -162,9 +163,9 @@ blockConcat splitting_procs g at CmmGraph { g_entry = entry_id }
-- Remember to update the shortcut_map, since we also have to
-- update the info_tbls mapping now.
(new_entry, shortcut_map')
- | Just entry_blk <- mapLookup entry_id new_blocks
+ | Just entry_blk <- Det.mapLookup entry_id new_blocks
, Just dest <- canShortcut entry_blk
- = (dest, mapInsert entry_id dest shortcut_map)
+ = (dest, NonDet.mapInsert entry_id dest shortcut_map)
| otherwise
= (entry_id, shortcut_map)
@@ -179,7 +180,7 @@ blockConcat splitting_procs g at CmmGraph { g_entry = entry_id }
-- * map containing number of predecessors for each block. We discard
-- it after we process all blocks.
(new_blocks, shortcut_map, _) =
- foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks
+ foldr maybe_concat (blockmap, NonDet.mapEmpty, initialBackEdges) blocks
-- Map of predecessors for initial graph. We increase number of
-- predecessors for entry block by one to denote that it is
@@ -188,8 +189,8 @@ blockConcat splitting_procs g at CmmGraph { g_entry = entry_id }
initialBackEdges = incPreds entry_id (predMap blocks)
maybe_concat :: CmmBlock
- -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
- -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
+ -> (Det.LabelMap CmmBlock, NonDet.LabelMap BlockId, NonDet.LabelMap Int)
+ -> (Det.LabelMap CmmBlock, NonDet.LabelMap BlockId, NonDet.LabelMap Int)
maybe_concat block (!blocks, !shortcut_map, !backEdges)
-- If:
-- (1) current block ends with unconditional branch to b' and
@@ -207,11 +208,11 @@ blockConcat splitting_procs g at CmmGraph { g_entry = entry_id }
-- we can ignore the contents of shortcut_map
| CmmBranch b' <- last
, hasOnePredecessor b'
- , Just blk' <- mapLookup b' blocks
+ , Just blk' <- Det.mapLookup b' blocks
= let bid' = entryLabel blk'
- in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks
+ in ( Det.mapDelete bid' $ Det.mapInsert bid (splice head blk') blocks
, shortcut_map
- , mapDelete b' backEdges )
+ , NonDet.mapDelete b' backEdges )
-- If:
-- (1) we are splitting proc points (see Note
@@ -229,10 +230,10 @@ blockConcat splitting_procs g at CmmGraph { g_entry = entry_id }
-- with dest.
| splitting_procs
, Just b' <- callContinuation_maybe last
- , Just blk' <- mapLookup b' blocks
+ , Just blk' <- Det.mapLookup b' blocks
, Just dest <- canShortcut blk'
- = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks
- , mapInsert b' dest shortcut_map
+ = ( Det.mapInsert bid (blockJoinTail head (update_cont dest)) blocks
+ , NonDet.mapInsert b' dest shortcut_map
, decPreds b' $ incPreds dest backEdges )
-- If:
@@ -249,7 +250,7 @@ blockConcat splitting_procs g at CmmGraph { g_entry = entry_id }
| Nothing <- callContinuation_maybe last
= let oldSuccs = successors last
newSuccs = successors rewrite_last
- in ( mapInsert bid (blockJoinTail head rewrite_last) blocks
+ in ( Det.mapInsert bid (blockJoinTail head rewrite_last) blocks
, shortcut_map
, if oldSuccs == newSuccs
then backEdges
@@ -273,7 +274,7 @@ blockConcat splitting_procs g at CmmGraph { g_entry = entry_id }
shortcut_last = mapSuccessors shortcut last
where
shortcut l =
- case mapLookup l blocks of
+ case Det.mapLookup l blocks of
Just b | Just dest <- canShortcut b -> dest
_otherwise -> l
@@ -307,7 +308,7 @@ blockConcat splitting_procs g at CmmGraph { g_entry = entry_id }
invertLikeliness = fmap not
-- Number of predecessors for a block
- numPreds bid = mapLookup bid backEdges `orElse` 0
+ numPreds bid = NonDet.mapLookup bid backEdges `orElse` 0
hasOnePredecessor b = numPreds b == 1
@@ -344,11 +345,11 @@ blockConcat splitting_procs g at 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 -> 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
- Just _ -> mapDelete bid edges
+incPreds, decPreds :: BlockId -> NonDet.LabelMap Int -> NonDet.LabelMap Int
+incPreds bid edges = NonDet.mapInsertWith (+) bid 1 edges
+decPreds bid edges = case NonDet.mapLookup bid edges of
+ Just preds | preds > 1 -> NonDet.mapInsert bid (preds - 1) edges
+ Just _ -> NonDet.mapDelete bid edges
_ -> edges
@@ -384,13 +385,13 @@ callContinuation_maybe _ = Nothing
-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied LabelMap.
-replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
+replaceLabels :: NonDet.LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels env g
- | mapNull env = g
+ | NonDet.mapNull env = g
| otherwise = replace_eid $ mapGraphNodes1 txnode g
where
replace_eid g = g {g_entry = lookup (g_entry g)}
- lookup id = mapLookup id env `orElse` id
+ lookup id = NonDet.mapLookup id env `orElse` id
txnode :: CmmNode e x -> CmmNode e x
txnode (CmmBranch bid) = CmmBranch (lookup bid)
@@ -409,21 +410,21 @@ replaceLabels env g
exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
exp e = e
-mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
+mkCmmCondBranch :: CmmExpr -> NonDet.Label -> NonDet.Label -> Maybe Bool -> CmmNode O C
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] -> LabelMap Int
-predMap blocks = foldr add_preds mapEmpty blocks
+predMap :: [CmmBlock] -> NonDet.LabelMap Int
+predMap blocks = foldr add_preds NonDet.mapEmpty blocks
where
add_preds block env = foldr add env (successors block)
- where add lbl env = mapInsertWith (+) lbl 1 env
+ where add lbl env = NonDet.mapInsertWith (+) lbl 1 env
-- Remove unreachable blocks from procs
removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl
removeUnreachableBlocksProc _ proc@(CmmProc info lbl live g)
- | used_blocks `lengthLessThan` mapSize (toBlockMap g)
+ | used_blocks `lengthLessThan` Det.mapSize (toBlockMap g)
= CmmProc info' lbl live g'
| otherwise
= proc
@@ -432,17 +433,17 @@ removeUnreachableBlocksProc _ proc@(CmmProc info lbl live g)
info' = info { info_tbls = keep_used (info_tbls info) }
-- Remove any info_tbls for unreachable
- keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
- keep_used bs = mapFoldlWithKey keep mapEmpty bs
+ keep_used :: Det.LabelMap CmmInfoTable -> Det.LabelMap CmmInfoTable
+ keep_used bs = Det.mapFoldlWithKey keep Det.mapEmpty bs
- keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
- keep env l i | l `setMember` used_lbls = mapInsert l i env
+ keep :: Det.LabelMap CmmInfoTable -> Det.Label -> CmmInfoTable -> Det.LabelMap CmmInfoTable
+ keep env l i | l `NonDet.setMember` used_lbls = Det.mapInsert l i env
| otherwise = env
used_blocks :: [CmmBlock]
used_blocks = revPostorder g
- used_lbls :: LabelSet
- used_lbls = setFromList $ map entryLabel used_blocks
+ used_lbls :: NonDet.LabelSet
+ used_lbls = NonDet.setFromList $ map entryLabel used_blocks
removeUnreachableBlocksProc platform data'@(CmmData _ _) =
pprPanic "removeUnreachableBlocksProc: passed data declaration instead of procedure" (pdoc platform data')
=====================================
compiler/GHC/Cmm/Dataflow/Graph.hs
=====================================
@@ -20,16 +20,18 @@ module GHC.Cmm.Dataflow.Graph
import GHC.Prelude
import GHC.Utils.Misc
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import GHC.Cmm.Dataflow.Label (Label)
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Cmm.Dataflow.Block
import Data.Kind
-- | A (possibly empty) collection of closed/closed blocks
-type Body n = LabelMap (Block n C C)
+type Body n = Det.LabelMap (Block n C C)
-- | @Body@ abstracted over @block@
-type Body' block (n :: Extensibility -> Extensibility -> Type) = LabelMap (block n C C)
+type Body' block (n :: Extensibility -> Extensibility -> Type) = Det.LabelMap (block n C C)
-------------------------------
-- | Gives access to the anchor points for
@@ -47,18 +49,18 @@ instance NonLocal n => NonLocal (Block n) where
emptyBody :: Body' block n
-emptyBody = mapEmpty
+emptyBody = Det.mapEmpty
bodyList :: Body' block n -> [(Label,block n C C)]
-bodyList body = mapToList body
+bodyList body = Det.mapToList body
bodyToBlockList :: Body n -> [Block n C C]
-bodyToBlockList body = mapElems body
+bodyToBlockList body = Det.mapElems body
addBlock
:: (NonLocal block, HasDebugCallStack)
- => block C C -> LabelMap (block C C) -> LabelMap (block C C)
-addBlock block body = mapAlter add lbl body
+ => block C C -> Det.LabelMap (block C C) -> Det.LabelMap (block C C)
+addBlock block body = Det.mapAlter add lbl body
where
lbl = entryLabel block
add Nothing = Just block
@@ -105,21 +107,21 @@ mapGraphBlocks f = map
where map :: Graph' block n e x -> Graph' block' n' e x
map GNil = GNil
map (GUnit b) = GUnit (f b)
- map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
+ map (GMany e b x) = GMany (fmap f e) (Det.mapMap f b) (fmap f x)
-- -----------------------------------------------------------------------------
-- Extracting Labels from graphs
labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
- -> LabelSet
-labelsDefined GNil = setEmpty
-labelsDefined (GUnit{}) = setEmpty
-labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
- where addEntry :: forall a. LabelSet -> Label -> a -> LabelSet
- addEntry labels label _ = setInsert label labels
- exitLabel :: MaybeO x (block n C O) -> LabelSet
- exitLabel NothingO = setEmpty
- exitLabel (JustO b) = setSingleton (entryLabel b)
+ -> NonDet.LabelSet
+labelsDefined GNil = NonDet.setEmpty
+labelsDefined (GUnit{}) = NonDet.setEmpty
+labelsDefined (GMany _ body x) = Det.mapFoldlWithKey addEntry (exitLabel x) body
+ where addEntry :: forall a. NonDet.LabelSet -> Label -> a -> NonDet.LabelSet
+ addEntry labels label _ = NonDet.setInsert label labels
+ exitLabel :: MaybeO x (block n C O) -> NonDet.LabelSet
+ exitLabel NothingO = NonDet.setEmpty
+ exitLabel (JustO b) = NonDet.setSingleton (entryLabel b)
----------------------------------------------------------------
@@ -148,8 +150,8 @@ labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
-- B and C before we analyze D.
revPostorderFrom
:: forall block. (NonLocal block)
- => LabelMap (block C C) -> Label -> [block C C]
-revPostorderFrom graph start = go start_worklist setEmpty []
+ => Det.LabelMap (block C C) -> Label -> [block C C]
+revPostorderFrom graph start = go start_worklist NonDet.setEmpty []
where
start_worklist = lookup_for_descend start Nil
@@ -165,22 +167,22 @@ revPostorderFrom graph start = go start_worklist setEmpty []
-- NOTE: We add blocks to the result list in postorder, but we *prepend*
-- them (i.e., we use @(:)@), which means that the final list is in reverse
-- postorder.
- go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
+ go :: DfsStack (block C C) -> NonDet.LabelSet -> [block C C] -> [block C C]
go Nil !_ !result = result
go (ConsMark block rest) !wip_or_done !result =
go rest wip_or_done (block : result)
go (ConsTodo block rest) !wip_or_done !result
- | entryLabel block `setMember` wip_or_done = go rest wip_or_done result
+ | entryLabel block `NonDet.setMember` wip_or_done = go rest wip_or_done result
| otherwise =
let new_worklist =
foldr lookup_for_descend
(ConsMark block rest)
(successors block)
- in go new_worklist (setInsert (entryLabel block) wip_or_done) result
+ in go new_worklist (NonDet.setInsert (entryLabel block) wip_or_done) result
lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
lookup_for_descend label wl
- | Just b <- mapLookup label graph = ConsTodo b wl
+ | Just b <- Det.mapLookup label graph = ConsTodo b wl
| otherwise =
error $ "Label that doesn't have a block?! " ++ show label
=====================================
compiler/GHC/Cmm/Dataflow/Label/NonDet.hs
=====================================
@@ -97,6 +97,7 @@ import qualified GHC.Data.Word64Map.Strict as M
import Data.List (foldl1')
import GHC.Cmm.Dataflow.Label (Label(..), mkHooplLabel)
+import GHC.Data.TrieMap (TrieMap(..))
-----------------------------------------------------------------------------
-- LabelSet
@@ -296,13 +297,13 @@ instance Outputable a => Outputable (LabelMap a) where
instance OutputableP env a => OutputableP env (LabelMap a) where
pdoc env = pdoc env . nonDetMapToList
--- instance TrieMap LabelMap where
--- type Key LabelMap = Label
--- emptyTM = mapEmpty
--- lookupTM k m = mapLookup k m
--- alterTM k f m = mapAlter f k m
--- foldTM k m z = mapFoldr k z m -- TODO:ERROR?
--- filterTM f m = mapFilter f m
+instance TrieMap LabelMap where
+ type Key LabelMap = Label
+ emptyTM = mapEmpty
+ lookupTM k m = mapLookup k m
+ alterTM k f m = mapAlter f k m
+ foldTM = error "TrieMap: NonDet.LabelMap"
+ filterTM f m = mapFilter f m
-----------------------------------------------------------------------------
-- FactBase
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -51,20 +51,20 @@ import GHC.Utils.Misc ( partitionWith, seqList )
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import Data.Maybe
import Data.List ( minimumBy, nubBy )
import Data.Ord ( comparing )
import qualified Data.Map as Map
-import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
-- | Debug information about a block of code. Ticks scope over nested
-- blocks.
data DebugBlock =
DebugBlock
- { dblProcedure :: !Label -- ^ Entry label of containing proc
- , dblLabel :: !Label -- ^ Hoopl label
+ { dblProcedure :: !NonDet.Label -- ^ Entry label of containing proc
+ , dblLabel :: !NonDet.Label -- ^ Hoopl label
, dblCLabel :: !CLabel -- ^ Output label
, dblHasInfoTbl :: !Bool -- ^ Has an info table?
, dblParent :: !(Maybe DebugBlock)
@@ -180,7 +180,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
}
where (CmmProc infos _entryLbl _ graph) = prc
label = entryLabel block
- info = mapLookup label infos
+ info = Det.mapLookup label infos
blocks | top = seqList childs childs
| otherwise = []
@@ -208,34 +208,34 @@ blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
-> Map.Map CmmTickScope [BlockContext]
walkProc CmmData{} m = m
walkProc prc@(CmmProc _ _ _ graph) m
- | mapNull blocks = m
+ | Det.mapNull blocks = m
| otherwise = snd $ walkBlock prc entry (emptyLbls, m)
where blocks = toBlockMap graph
entry = [mapFind (g_entry graph) blocks]
- emptyLbls = setEmpty :: LabelSet
+ emptyLbls = NonDet.setEmpty :: NonDet.LabelSet
walkBlock :: RawCmmDecl -> [Block CmmNode C C]
- -> (LabelSet, Map.Map CmmTickScope [BlockContext])
- -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+ -> (NonDet.LabelSet, Map.Map CmmTickScope [BlockContext])
+ -> (NonDet.LabelSet, Map.Map CmmTickScope [BlockContext])
walkBlock _ [] c = c
walkBlock prc (block:blocks) (visited, m)
- | lbl `setMember` visited
+ | lbl `NonDet.setMember` visited
= walkBlock prc blocks (visited, m)
| otherwise
= walkBlock prc blocks $
walkBlock prc succs
- (lbl `setInsert` visited,
+ (lbl `NonDet.setInsert` visited,
insertMulti scope (block, prc) m)
where CmmEntry lbl scope = firstNode block
(CmmProc _ _ _ graph) = prc
succs = map (flip mapFind (toBlockMap graph))
(successors (lastNode block))
- mapFind = mapFindWithDefault (error "contextTree: block not found!")
+ mapFind = Det.mapFindWithDefault (error "contextTree: block not found!")
insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
insertMulti k v = Map.insertWith (const (v:)) k [v]
-cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
+cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [NonDet.Label]
cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls
where -- Find order in which procedures will be generated by the
-- back-end (that actually matters for DWARF generation).
@@ -251,12 +251,12 @@ cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls
-- | Sets position and unwind table fields in the debug block tree according to
-- native generated code.
-cmmDebugLink :: [Label] -> NonDet.LabelMap [UnwindPoint]
+cmmDebugLink :: [NonDet.Label] -> NonDet.LabelMap [UnwindPoint]
-> [DebugBlock] -> [DebugBlock]
cmmDebugLink labels unwindPts blocks = mapMaybe link blocks
- where blockPos :: LabelMap Int
- blockPos = mapFromList $ flip zip [0..] labels
- link block = case mapLookup (dblLabel block) blockPos of
+ where blockPos :: NonDet.LabelMap Int
+ blockPos = NonDet.mapFromList $ flip zip [0..] labels
+ link block = case NonDet.mapLookup (dblLabel block) blockPos of
-- filter dead blocks: we generated debug infos from Cmm blocks but
-- asm-shortcutting may remove some blocks later (#22792)
Nothing -> Nothing
@@ -267,9 +267,9 @@ cmmDebugLink labels unwindPts blocks = mapMaybe link blocks
}
-- | Converts debug blocks into a label map for easier lookups
-debugToMap :: [DebugBlock] -> LabelMap DebugBlock
-debugToMap = mapUnions . map go
- where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)
+debugToMap :: [DebugBlock] -> NonDet.LabelMap DebugBlock
+debugToMap = NonDet.mapUnions . map go
+ where go b = NonDet.mapInsert (dblLabel b) b $ NonDet.mapUnions $ map go (dblBlocks b)
{-
Note [What is this unwinding business?]
=====================================
compiler/GHC/Cmm/Dominators.hs
=====================================
@@ -32,7 +32,9 @@ import qualified GHC.CmmToAsm.CFG.Dominators as LT
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Dataflow.Label (Label)
+import qualified GHC.Cmm.Dataflow.Label as Det
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Cmm
import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>))
@@ -112,8 +114,8 @@ intersectDominators ds ds' = commonPrefix (revDoms ds []) (revDoms ds' []) Entry
-- Invariant: Dominators, graph, and RP numberings include only *reachable* blocks.
data GraphWithDominators node =
GraphWithDominators { gwd_graph :: GenCmmGraph node
- , gwd_dominators :: LabelMap DominatorSet
- , gwd_rpnumbering :: LabelMap RPNum
+ , gwd_dominators :: NonDet.LabelMap DominatorSet
+ , gwd_rpnumbering :: NonDet.LabelMap RPNum
}
@@ -138,14 +140,14 @@ graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap
rplabels :: Array Word64 Label
rplabels = listArray bounds rplabels'
- rpmap :: LabelMap RPNum
- rpmap = mapFromList $ zipWith kvpair rpblocks [0..]
+ rpmap :: NonDet.LabelMap RPNum
+ rpmap = NonDet.mapFromList $ zipWith kvpair rpblocks [0..]
where kvpair block i = (entryLabel block, RPNum i)
labelIndex :: Label -> Word64
labelIndex = flip findLabelIn imap
- where imap :: LabelMap Word64
- imap = mapFromList $ zip rplabels' [0..]
+ where imap :: NonDet.LabelMap Word64
+ imap = NonDet.mapFromList $ zip rplabels' [0..]
blockIndex = labelIndex . entryLabel
bounds :: (Word64, Word64)
@@ -167,18 +169,18 @@ graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap
where d = idom_array ! i
doms = tabulate bounds domSet
- dmap = mapFromList $ zipWith (\lbl i -> (lbl, domSet i)) rplabels' [0..]
+ dmap = NonDet.mapFromList $ zipWith (\lbl i -> (lbl, domSet i)) rplabels' [0..]
reachable :: NonLocal node => [Block node C C] -> GenCmmGraph node -> GenCmmGraph node
reachable blocks g = g { g_graph = GMany NothingO blockmap NothingO }
- where blockmap = mapFromList [(entryLabel b, b) | b <- blocks]
+ where blockmap = Det.mapFromList [(entryLabel b, b) | b <- blocks]
-- | =Utility functions
-- | Call `graphMap` to get the mapping from `Label` to `Block` that
-- is embedded in every `CmmGraph`.
-graphMap :: GenCmmGraph n -> LabelMap (Block n C C)
+graphMap :: GenCmmGraph n -> Det.LabelMap (Block n C C)
graphMap (CmmGraph { g_graph = GMany NothingO blockmap NothingO }) = blockmap
-- | Use `gwdRPNumber` on the result of the dominator analysis to get
@@ -187,8 +189,8 @@ graphMap (CmmGraph { g_graph = GMany NothingO blockmap NothingO }) = blockmap
gwdRPNumber :: HasDebugCallStack => GraphWithDominators node -> Label -> RPNum
gwdRPNumber g l = findLabelIn l (gwd_rpnumbering g)
-findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a
-findLabelIn lbl = mapFindWithDefault failed lbl
+findLabelIn :: HasDebugCallStack => Label -> NonDet.LabelMap a -> a
+findLabelIn lbl = NonDet.mapFindWithDefault failed lbl
where failed =
pprPanic "label not found in result of analysis" (ppr lbl)
@@ -204,12 +206,12 @@ gwdDominatorsOf g lbl = findLabelIn lbl (gwd_dominators g)
gwdDominatorTree :: GraphWithDominators node -> Tree.Tree Label
gwdDominatorTree gwd = subtreeAt (g_entry (gwd_graph gwd))
where subtreeAt label = Tree.Node label $ map subtreeAt $ children label
- children l = mapFindWithDefault [] l child_map
- child_map :: LabelMap [Label]
- child_map = mapFoldlWithKey addParent mapEmpty $ gwd_dominators gwd
+ children l = NonDet.mapFindWithDefault [] l child_map
+ child_map :: NonDet.LabelMap [Label]
+ child_map = NonDet.nonDetMapFoldlWithKey addParent NonDet.mapEmpty $ gwd_dominators gwd
where addParent cm _ EntryNode = cm
addParent cm lbl (ImmediateDominator p _) =
- mapInsertWith (++) p [lbl] cm
+ NonDet.mapInsertWith (++) p [lbl] cm
-- | Turn a function into an array. Inspired by SML's `Array.tabulate`
=====================================
compiler/GHC/Cmm/Info.hs
=====================================
@@ -40,7 +40,7 @@ import GHC.Runtime.Heap.Layout
import GHC.Data.Bitmap
import GHC.Data.Stream (Stream)
import qualified GHC.Data.Stream as Stream
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
import GHC.Platform
import GHC.Platform.Profile
@@ -133,7 +133,7 @@ mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks)
= case topInfoTable proc of -- must be at most one
-- no info table
Nothing ->
- return [CmmProc mapEmpty entry_lbl live blocks]
+ return [CmmProc Det.mapEmpty entry_lbl live blocks]
Just info at CmmInfoTable { cit_lbl = info_lbl } -> do
(top_decls, (std_info, extra_bits)) <-
@@ -146,7 +146,7 @@ mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks)
-- point as first entry) and the entry code
--
return (top_decls ++
- [CmmProc mapEmpty entry_lbl live blocks,
+ [CmmProc Det.mapEmpty entry_lbl live blocks,
mkRODataLits info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
@@ -159,9 +159,9 @@ mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks)
| otherwise
= do
(top_declss, raw_infos) <-
- unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
+ unzip `fmap` mapM do_one_info (Det.mapToList (info_tbls infos))
return (concat top_declss ++
- [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
+ [CmmProc (Det.mapFromList raw_infos) entry_lbl live blocks])
where
platform = profilePlatform profile
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -26,8 +26,8 @@ import GHC.Cmm.BlockId
import GHC.Cmm.Config
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Dataflow.Label.NonDet (lookupFact)
+import qualified GHC.Cmm.Dataflow.Label as Det
+import GHC.Cmm.Dataflow.Label.NonDet (lookupFact, Label)
import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Cmm.Dataflow
import GHC.Unit.Module
@@ -596,7 +596,7 @@ cafAnalData platform st = case st of
--
cafAnal
:: Platform
- -> LabelSet -- ^ The blocks representing continuations, ie. those
+ -> NonDet.LabelSet -- ^ The blocks representing continuations, ie. those
-- that will get RET info tables. These labels will
-- get their own SRTs, so we don't aggregate CAFs from
-- references to these labels, we just use the label.
@@ -616,7 +616,7 @@ cafLattice = DataflowLattice Set.empty add
in changedIf (Set.size new' > Set.size old) new'
-cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
+cafTransfers :: Platform -> NonDet.LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers platform contLbls entry topLbl
block@(BlockCC eNode middle xNode) fBase =
let joined :: CAFSet
@@ -638,7 +638,7 @@ cafTransfers platform contLbls entry topLbl
| s == entry = Just (addCafLabel platform topLbl Set.empty)
-- If this is a continuation, we want to refer to the
-- SRT for the continuation's info table
- | s `setMember` contLbls
+ | s `NonDet.setMember` contLbls
= Just (Set.singleton (mkCAFfyLabel platform (infoTblLbl s)))
-- Otherwise, takes the CAF references from the destination
| otherwise
@@ -746,7 +746,7 @@ getLabelledBlocks platform decl = case decl of
| not (isThunkRep (cit_rep info))
]
CmmProc top_info _ _ _ -> [ (BlockLabel blockId, caf_lbl)
- | (blockId, info) <- mapToList (info_tbls top_info)
+ | (blockId, info) <- Det.mapToList (info_tbls top_info)
, let rep = cit_rep info
, not (isStaticRep rep) || not (isThunkRep rep)
, let !caf_lbl = mkCAFfyLabel platform (cit_lbl info)
@@ -813,7 +813,7 @@ getCAFs platform cafEnv = mapMaybe getCAFLabel
getCAFLabel :: CmmDecl -> Maybe (Maybe Label, CAFfyLabel, Set CAFfyLabel)
getCAFLabel (CmmProc top_info top_lbl _ g)
- | Just info <- mapLookup (g_entry g) (info_tbls top_info)
+ | Just info <- Det.mapLookup (g_entry g) (info_tbls top_info)
, let rep = cit_rep info
, isStaticRep rep && isThunkRep rep
, Just cafs <- NonDet.mapLookup (g_entry g) cafEnv
@@ -839,7 +839,7 @@ getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
getStaticFuns decls =
[ (g_entry g, lbl)
| CmmProc top_info _ _ g <- decls
- , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+ , Just info <- [Det.mapLookup (g_entry g) (info_tbls top_info)]
, Just (id, _) <- [cit_clo info]
, let rep = cit_rep info
, isStaticRep rep && isFunRep rep
@@ -911,7 +911,7 @@ doSRTs cfg moduleSRTInfo dus procs data_ = do
(proc_envs, procss) = unzip procs
cafEnv = NonDet.mapUnions proc_envs
decls = map (cmmDataDeclCmmDecl . snd) data_ ++ concat procss
- staticFuns = mapFromList (getStaticFuns decls)
+ staticFuns = NonDet.mapFromList (getStaticFuns decls)
platform = cmmPlatform cfg
@@ -957,8 +957,8 @@ doSRTs cfg moduleSRTInfo dus procs data_ = do
-- Next, update the info tables with the SRTs
let
- srtFieldMap = mapFromList (concat pairs)
- funSRTMap = mapFromList (concat funSRTs)
+ srtFieldMap = NonDet.mapFromList (concat pairs)
+ funSRTMap = NonDet.mapFromList (concat funSRTs)
has_caf_refs' = anyCafRefs has_caf_refs
decls' =
concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls
@@ -990,7 +990,7 @@ doSRTs cfg moduleSRTInfo dus procs data_ = do
-- | Build the SRT for a strongly-connected component of blocks.
doSCC
:: CmmConfig
- -> LabelMap CLabel -- ^ which blocks are static function entry points
+ -> NonDet.LabelMap CLabel -- ^ which blocks are static function entry points
-> DataCAFEnv -- ^ static data
-> SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)
-> StateT ModuleSRTInfo UniqDSM
@@ -1042,7 +1042,7 @@ However, there are a couple of wrinkles to be aware of.
-- | Build an SRT for a set of blocks
oneSRT
:: CmmConfig
- -> LabelMap CLabel -- ^ which blocks are static function entry points
+ -> NonDet.LabelMap CLabel -- ^ which blocks are static function entry points
-> [SomeLabel] -- ^ blocks in this set
-> [CAFfyLabel] -- ^ labels for those blocks
-> Bool -- ^ True <=> this SRT is for a CAF
@@ -1070,7 +1070,7 @@ oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data_env = do
maybeFunClosure :: Maybe (CLabel, Label)
otherFunLabels :: [CLabel]
(maybeFunClosure, otherFunLabels) =
- case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
+ case [ (l,b) | b <- blockids, Just l <- [NonDet.mapLookup b staticFuns] ] of
[] -> (Nothing, [])
((l,b):xs) -> (Just (l,b), map fst xs)
@@ -1277,8 +1277,8 @@ buildSRT profile refs = do
-- static closures, splicing in SRT fields as necessary.
updInfoSRTs
:: Profile
- -> LabelMap CLabel -- ^ SRT labels for each block
- -> LabelMap [SRTEntry] -- ^ SRTs to merge into FUN_STATIC closures
+ -> NonDet.LabelMap CLabel -- ^ SRT labels for each block
+ -> NonDet.LabelMap [SRTEntry] -- ^ SRTs to merge into FUN_STATIC closures
-> CafInfo -- ^ Whether the CmmDecl's group has CAF references
-> CmmDecl
-> [CmmDeclSRTs]
@@ -1296,10 +1296,10 @@ updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
| otherwise = [ proc ]
where
proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
- newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
+ newTopInfo = Det.mapMapWithKey updInfoTbl (info_tbls top_info)
updInfoTbl l info_tbl
| l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
- | otherwise = info_tbl { cit_srt = mapLookup l srt_env }
+ | otherwise = info_tbl { cit_srt = NonDet.mapLookup l srt_env }
-- Generate static closures [FUN]. Note that this also generates
-- static closures for thunks (CAFs), because it's easier to treat
@@ -1307,15 +1307,15 @@ updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
maybeStaticClosure
| Just info_tbl at CmmInfoTable{..} <-
- mapLookup (g_entry g) (info_tbls top_info)
+ Det.mapLookup (g_entry g) (info_tbls top_info)
, Just (id, ccs) <- cit_clo
, isStaticRep cit_rep =
let
- (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
+ (newInfo, srtEntries) = case NonDet.mapLookup (g_entry g) funSRTEnv of
Nothing ->
-- if we don't add SRT entries to this closure, then we
-- want to set the srt field in its info table as usual
- (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
+ (info_tbl { cit_srt = NonDet.mapLookup (g_entry g) srt_env }, [])
Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)
(info_tbl { cit_rep = new_rep }, res)
where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
=====================================
compiler/GHC/Cmm/LayoutStack.hs
=====================================
@@ -24,7 +24,7 @@ import GHC.Runtime.Heap.Layout
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Data.Maybe
import GHC.Types.Unique.FM
@@ -262,7 +262,7 @@ cmmLayoutStack cfg procpoints entry_args
-- -----------------------------------------------------------------------------
layout :: CmmConfig
- -> LabelSet -- proc points
+ -> NonDet.LabelSet -- proc points
-> NonDet.LabelMap CmmLocalLive -- liveness
-> BlockId -- entry
-> ByteOff -- stack args on entry
@@ -372,13 +372,13 @@ isGcJump _something_else = False
-- unnecessarily pessimistic, but probably not in the code we
-- generate.
-collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)
+collectContInfo :: [CmmBlock] -> (ByteOff, NonDet.LabelMap ByteOff)
collectContInfo blocks
- = (maximum ret_offs, mapFromList (catMaybes mb_argss))
+ = (maximum ret_offs, NonDet.mapFromList (catMaybes mb_argss))
where
(mb_argss, ret_offs) = mapAndUnzip get_cont blocks
- get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
+ get_cont :: Block CmmNode x C -> (Maybe (NonDet.Label, ByteOff), ByteOff)
get_cont b =
case lastNode b of
CmmCall { cml_cont = Just l, .. }
@@ -439,7 +439,7 @@ getStackLoc (Young l) n stackmaps =
-- extra code that goes *after* the Sp adjustment.
handleLastNode
- :: CmmConfig -> ProcPointSet -> NonDet.LabelMap CmmLocalLive -> LabelMap ByteOff
+ :: CmmConfig -> ProcPointSet -> NonDet.LabelMap CmmLocalLive -> NonDet.LabelMap ByteOff
-> NonDet.LabelMap StackMap -> StackMap -> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
@@ -518,9 +518,9 @@ handleLastNode cfg procpoints liveness cont_info stackmaps
handleBranches
-- See Note [diamond proc point]
| Just l <- futureContinuation middle
- , (nub $ filter (`setMember` procpoints) $ successors last) == [l]
+ , (nub $ filter (`NonDet.setMember` procpoints) $ successors last) == [l]
= do
- let cont_args = mapFindWithDefault 0 l cont_info
+ let cont_args = NonDet.mapFindWithDefault 0 l cont_info
(assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)
out = NonDet.mapFromList
[ (l', cont_stack)
@@ -533,9 +533,9 @@ handleLastNode cfg procpoints liveness cont_info stackmaps
| otherwise = do
pps <- mapM handleBranch (successors last)
- let lbl_map :: LabelMap Label
- lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
- fix_lbl l = mapFindWithDefault l l lbl_map
+ let lbl_map :: NonDet.LabelMap Det.Label
+ lbl_map = NonDet.mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
+ fix_lbl l = NonDet.mapFindWithDefault l l lbl_map
return ( []
, 0
, mapSuccessors fix_lbl last
@@ -556,9 +556,9 @@ handleLastNode cfg procpoints liveness cont_info stackmaps
-- (b) if the successor is a proc point, save everything
-- on the stack.
- | l `setMember` procpoints
+ | l `NonDet.setMember` procpoints
= do
- let cont_args = mapFindWithDefault 0 l cont_info
+ let cont_args = NonDet.mapFindWithDefault 0 l cont_info
(stack2, assigs) =
setupStackFrame platform l liveness (sm_ret_off stack0)
cont_args stack0
@@ -576,9 +576,9 @@ handleLastNode cfg procpoints liveness cont_info stackmaps
is_live (r,_) = r `elemRegSet` live
-makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap
+makeFixupBlock :: CmmConfig -> ByteOff -> Det.Label -> StackMap
-> CmmTickScope -> [CmmNode O O]
- -> UniqDSM (Label, [CmmBlock])
+ -> UniqDSM (Det.Label, [CmmBlock])
makeFixupBlock cfg sp0 l stack tscope assigs
| null assigs && sp0 == sm_sp stack = return (l, [])
| otherwise = do
@@ -1019,7 +1019,7 @@ elimStackStores stackmap stackmaps area_off nodes
setInfoTableStackMap :: Platform -> NonDet.LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap platform stackmaps (CmmProc top_info at TopInfo{..} l v g)
- = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
+ = CmmProc top_info{ info_tbls = Det.mapMapWithKey fix_info info_tbls } l v g
where
fix_info lbl info_tbl at CmmInfoTable{ cit_rep = StackRep _ } =
info_tbl { cit_rep = StackRep (get_liveness lbl) }
@@ -1078,7 +1078,7 @@ insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks =
-- they're actually live. Furthermore, nothing is live at the entry
-- to a proc point.
(middle1, live_with_reloads)
- | entry_label `setMember` procpoints
+ | entry_label `NonDet.setMember` procpoints
= let reloads = insertReloads platform stackmap live_at_middle0
in (foldr blockCons middle0 reloads, emptyRegSet)
| otherwise
=====================================
compiler/GHC/Cmm/Node.hs
=====================================
@@ -35,7 +35,9 @@ import GHC.Types.Basic (FunctionOrData(..))
import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
+import GHC.Cmm.Dataflow.Label (Label)
import Data.Foldable (toList)
import Data.Functor.Classes (liftCompare)
import Data.Maybe
@@ -47,7 +49,7 @@ import GHC.Utils.Constants (debugIsOn)
------------------------
-- CmmNode
-#define ULabel {-# UNPACK #-} !Label
+#define ULabel {-# UNPACK #-} !Det.Label
data CmmNode e x where
CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
@@ -108,7 +110,7 @@ data CmmNode e x where
CmmCall :: { -- A native call or tail call
cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
- cml_cont :: Maybe Label,
+ cml_cont :: Maybe Det.Label,
-- Label of continuation (Nothing for return or tail call)
--
-- Note [Continuation BlockIds]
@@ -797,11 +799,12 @@ mapCollectSuccessors f (CmmCondBranch p y n l)
in (CmmCondBranch p bidt bidf l, [accf, acct])
mapCollectSuccessors f (CmmSwitch e ids)
= let lbls = switchTargetsToList ids :: [Label]
- lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)
+ res = map f lbls
+ lblMap = NonDet.mapFromList $ zip lbls res :: NonDet.LabelMap (Label, a)
in ( CmmSwitch e
(mapSwitchTargets
- (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)
- , map snd (mapElems lblMap)
+ (\l -> fst $ NonDet.mapFindWithDefault (error "impossible") l lblMap) ids)
+ , map snd res
)
mapCollectSuccessors _ n = (n, [])
=====================================
compiler/GHC/Cmm/ProcPoint.hs
=====================================
@@ -28,7 +28,8 @@ import GHC.Types.Unique.DSM
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import GHC.Cmm.Dataflow.Label (Label)
import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
-- Compute a minimal set of proc points for a control-flow graph.
@@ -116,7 +117,7 @@ if a proc-point does not exist anymore then we will get compiler panic.
See #8205.
-}
-type ProcPointSet = LabelSet
+type ProcPointSet = NonDet.LabelSet
data Status
= ReachedBy ProcPointSet -- set of proc points that directly reach the block
@@ -124,9 +125,9 @@ data Status
instance Outputable Status where
ppr (ReachedBy ps)
- | setNull ps = text "<not-reached>"
+ | NonDet.setNull ps = text "<not-reached>"
| otherwise = text "reached by" <+>
- (hsep $ punctuate comma $ map ppr $ setElems ps)
+ (hsep $ punctuate comma $ map ppr $ NonDet.nonDetSetElems ps)
ppr ProcPoint = text "<procpt>"
--------------------------------------------------
@@ -143,9 +144,9 @@ procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
mkFactBase
procPointLattice
[ (id, ProcPoint)
- | id <- setElems procPoints
+ | id <- NonDet.nonDetSetElems procPoints
-- See Note [Non-existing proc-points]
- , id `setMember` labelsInGraph
+ , id `NonDet.setMember` labelsInGraph
]
labelsInGraph = labelsDefined graph
@@ -153,7 +154,7 @@ procPointTransfer :: TransferFun Status
procPointTransfer block facts =
let label = entryLabel block
!fact = case getFact procPointLattice label facts of
- ProcPoint -> ReachedBy $! setSingleton label
+ ProcPoint -> ReachedBy $! NonDet.setSingleton label
f -> f
result = map (\id -> (id, fact)) (successors block)
in mkFactBase procPointLattice result
@@ -161,14 +162,14 @@ procPointTransfer block facts =
procPointLattice :: DataflowLattice Status
procPointLattice = DataflowLattice unreached add_to
where
- unreached = ReachedBy setEmpty
+ unreached = ReachedBy NonDet.setEmpty
add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
- | setSize union > setSize p = Changed (ReachedBy union)
+ | NonDet.setSize union > NonDet.setSize p = Changed (ReachedBy union)
| otherwise = NotChanged (ReachedBy p)
where
- union = setUnion p' p
+ union = NonDet.setUnion p' p
----------------------------------------------------------------------
@@ -178,11 +179,11 @@ procPointLattice = DataflowLattice unreached add_to
--
-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
callProcPoints :: CmmGraph -> ProcPointSet
-callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g
- where add :: LabelSet -> CmmBlock -> LabelSet
+callProcPoints g = foldlGraphBlocks add (NonDet.setSingleton (g_entry g)) g
+ where add :: NonDet.LabelSet -> CmmBlock -> NonDet.LabelSet
add set b = case lastNode b of
- CmmCall {cml_cont = Just k} -> setInsert k set
- CmmForeignCall {succ=k} -> setInsert k set
+ CmmCall {cml_cont = Just k} -> NonDet.setInsert k set
+ CmmForeignCall {succ=k} -> NonDet.setInsert k set
_ -> set
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
@@ -198,29 +199,29 @@ extendPPSet platform g blocks procPoints =
let env = procPointAnalysis procPoints g
add pps block = let id = entryLabel block
in case NonDet.mapLookup id env of
- Just ProcPoint -> setInsert id pps
+ Just ProcPoint -> NonDet.setInsert id pps
_ -> pps
- procPoints' = foldlGraphBlocks add setEmpty g
+ procPoints' = foldlGraphBlocks add NonDet.setEmpty g
newPoints = mapMaybe ppSuccessor blocks
newPoint = listToMaybe newPoints
ppSuccessor b =
let nreached id = case NonDet.mapLookup id env `orElse`
pprPanic "no ppt" (ppr id <+> pdoc platform b) of
ProcPoint -> 1
- ReachedBy ps -> setSize ps
+ ReachedBy ps -> NonDet.setSize ps
block_procpoints = nreached (entryLabel b)
-- Looking for a successor of b that is reached by
-- more proc points than b and is not already a proc
-- point. If found, it can become a proc point.
- newId succ_id = not (setMember succ_id procPoints') &&
+ newId succ_id = not (NonDet.setMember succ_id procPoints') &&
nreached succ_id > block_procpoints
in listToMaybe $ filter newId $ successors b
in case newPoint of
Just id ->
- if setMember id procPoints'
+ if NonDet.setMember id procPoints'
then panic "added old proc pt"
- else extendPPSet platform g blocks (setInsert id procPoints')
+ else extendPPSet platform g blocks (NonDet.setInsert id procPoints')
Nothing -> return procPoints'
@@ -243,17 +244,17 @@ splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
-- Build a map from procpoints to the blocks they reach
let (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = cmmProc
- let add graphEnv procId bid b = mapInsert procId graph' graphEnv
+ let add graphEnv procId bid b = NonDet.mapInsert procId graph' graphEnv
where
- graph' = mapInsert bid b graph
- graph = mapLookup procId graphEnv `orElse` mapEmpty
+ graph' = Det.mapInsert bid b graph
+ graph = NonDet.mapLookup procId graphEnv `orElse` Det.mapEmpty
- let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock)
+ let add_block :: NonDet.LabelMap (Det.LabelMap CmmBlock) -> CmmBlock -> NonDet.LabelMap (Det.LabelMap CmmBlock)
add_block graphEnv b =
case NonDet.mapLookup bid procMap of
Just ProcPoint -> add graphEnv bid bid b
Just (ReachedBy set) ->
- case setElems set of
+ case NonDet.nonDetSetElems set of
[] -> graphEnv
[id] -> add graphEnv id bid b
_ -> panic "Each block should be reachable from only one ProcPoint"
@@ -265,35 +266,35 @@ splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
let liveness = cmmGlobalLiveness platform g
let ppLiveness pp = filter isArgReg $ regSetToList $
expectJust "ppLiveness" $ NonDet.mapLookup pp liveness
- graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g
+ graphEnv <- return $ foldlGraphBlocks add_block NonDet.mapEmpty g
-- Build a map from proc point BlockId to pairs of:
-- * Labels for their new procedures
-- * Labels for the info tables of their new procedures (only if
-- the proc point is a callPP)
-- Due to common blockification, we may overestimate the set of procpoints.
- let add_label map pp = mapInsert pp lbls map
- where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
- | otherwise = (block_lbl, guard (setMember pp callPPs) >>
+ let add_label map pp = NonDet.mapInsert pp lbls map
+ where lbls | pp == entry = (entry_label, fmap cit_lbl (Det.mapLookup entry info_tbls))
+ | otherwise = (block_lbl, guard (NonDet.setMember pp callPPs) >>
Just info_table_lbl)
where block_lbl = blockLbl pp
info_table_lbl = infoTblLbl pp
- procLabels :: LabelMap (CLabel, Maybe CLabel)
- procLabels = foldl' add_label mapEmpty
- (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+ procLabels :: NonDet.LabelMap (CLabel, Maybe CLabel)
+ procLabels = foldl' add_label NonDet.mapEmpty
+ (filter (flip Det.mapMember (toBlockMap g)) (NonDet.nonDetSetElems procPoints))
-- 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 :: (LabelMap Label, [CmmBlock])
+ let add_jump_block :: (NonDet.LabelMap Label, [CmmBlock])
-> (Label, CLabel)
- -> UniqDSM (LabelMap Label, [CmmBlock])
+ -> UniqDSM (NonDet.LabelMap Label, [CmmBlock])
add_jump_block (env, bs) (pp, l) = do
bid <- liftM mkBlockId getUniqueDSM
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)
+ return (NonDet.mapInsert pp bid env, b : bs)
-- when jumping to a PP that has an info table, if
-- tablesNextToCode is off we must jump to the entry
@@ -306,7 +307,7 @@ splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
jump_label Nothing block_lbl = block_lbl
let add_if_pp id rst =
- case mapLookup id procLabels of
+ case NonDet.mapLookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
Nothing -> rst
@@ -318,25 +319,25 @@ splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids
_ -> rst
- let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqDSM (LabelMap CmmGraph)
+ let add_jumps :: NonDet.LabelMap CmmGraph -> (Label, Det.LabelMap CmmBlock) -> UniqDSM (NonDet.LabelMap CmmGraph)
add_jumps newGraphEnv (ppId, blockEnv) = do
-- find which procpoints we currently branch to
- let needed_jumps = mapFoldr add_if_branch_to_pp [] blockEnv
+ let needed_jumps = Det.mapFoldr add_if_branch_to_pp [] blockEnv
(jumpEnv, jumpBlocks) <-
- foldM add_jump_block (mapEmpty, []) needed_jumps
+ foldM add_jump_block (NonDet.mapEmpty, []) needed_jumps
-- update the entry block
- let b = expectJust "block in env" $ mapLookup ppId blockEnv
- blockEnv' = mapInsert ppId b blockEnv
+ let b = expectJust "block in env" $ Det.mapLookup ppId blockEnv
+ blockEnv' = Det.mapInsert ppId b blockEnv
-- replace branches to procpoints with branches to jumps
blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
-- add the jump blocks to the graph
blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks
let g' = ofBlockMap ppId blockEnv'''
-- pprTrace "g' pre jumps" (ppr g') $ do
- return (mapInsert ppId g' newGraphEnv)
+ return (NonDet.mapInsert ppId g' newGraphEnv)
- graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
+ graphEnv <- foldM add_jumps NonDet.mapEmpty $ NonDet.nonDetMapToList graphEnv
let to_proc (bid, g)
| bid == entry
@@ -344,13 +345,13 @@ splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
stack_info = stack_info})
top_l live g'
| otherwise
- = case expectJust "pp label" $ mapLookup bid procLabels of
+ = case expectJust "pp label" $ NonDet.mapLookup bid procLabels of
(lbl, Just info_lbl)
- -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
+ -> CmmProc (TopInfo { info_tbls = Det.mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
, stack_info=stack_info})
lbl live g'
(lbl, Nothing)
- -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
+ -> CmmProc (TopInfo {info_tbls = Det.mapEmpty, stack_info=stack_info})
lbl live g'
where
g' = replacePPIds g
@@ -364,7 +365,7 @@ splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
replacePPIds g = {-# SCC "replacePPIds" #-}
mapGraphNodes (id, mapExp repl, mapExp repl) g
where repl e@(CmmLit (CmmBlock bid)) =
- case mapLookup bid procLabels of
+ case NonDet.mapLookup bid procLabels of
Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
_ -> e
repl e = e
@@ -373,22 +374,22 @@ splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
-- call sites. Here, we sort them in reverse order -- it gets
-- reversed later.
let add_block_num (i, map) block =
- (i + 1, mapInsert (entryLabel block) i map)
+ (i + 1, NonDet.mapInsert (entryLabel block) i map)
let (_, block_order) =
- foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
+ foldl' add_block_num (0::Int, NonDet.mapEmpty :: NonDet.LabelMap Int)
(revPostorder g)
let sort_fn (bid, _) (bid', _) =
- compare (expectJust "block_order" $ mapLookup bid block_order)
- (expectJust "block_order" $ mapLookup bid' block_order)
+ compare (expectJust "block_order" $ NonDet.mapLookup bid block_order)
+ (expectJust "block_order" $ NonDet.mapLookup bid' block_order)
- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
+ return $ map to_proc $ sortBy sort_fn $ NonDet.nonDetMapToList graphEnv
-- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a
-- recursive lookup, see comment below.
-replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
+replaceBranches :: NonDet.LabelMap BlockId -> CmmGraph -> CmmGraph
replaceBranches env cmmg
= {-# SCC "replaceBranches" #-}
- ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
+ ofBlockMap (g_entry cmmg) $ Det.mapMap f $ toBlockMap cmmg
where
f block = replaceLastNode block $ last (lastNode block)
@@ -401,7 +402,7 @@ replaceBranches env cmmg
-- label will now be in a different CmmProc. Not only
-- is this tidier, it stops CmmLint from complaining.
last l@(CmmForeignCall {}) = l
- lookup id = fmap lookup (mapLookup id env) `orElse` id
+ lookup id = fmap lookup (NonDet.mapLookup id env) `orElse` id
-- XXX: this is a recursive lookup, it follows chains
-- until the lookup returns Nothing, at which point we
-- return the last BlockId
@@ -413,9 +414,9 @@ attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
= CmmProc top_info{info_tbls = info_tbls'} top_l live g
where
- info_tbls' = mapUnion (info_tbls top_info) $
- mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
- | l <- setElems call_proc_points
+ info_tbls' = Det.mapUnion (info_tbls top_info) $
+ Det.mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
+ | l <- NonDet.nonDetSetElems call_proc_points
, l /= g_entry g ]
attachContInfoTables _ other_decl
= other_decl
=====================================
compiler/GHC/Cmm/Reducibility.hs
=====================================
@@ -43,7 +43,9 @@ import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dominators
import GHC.Cmm.Dataflow.Graph hiding (addBlock)
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
+import GHC.Cmm.Dataflow.Label (Label)
import GHC.Data.Graph.Collapse
import GHC.Data.Graph.Inductive.Graph
import GHC.Data.Graph.Inductive.PatriciaTree
@@ -110,8 +112,8 @@ type CGraph = Gr CmmSuper ()
inflate :: Label -> CGraph -> CmmGraph
inflate entry cg = CmmGraph entry graph
where graph = GMany NothingO body NothingO
- body :: LabelMap CmmBlock
- body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $
+ body :: Det.LabelMap CmmBlock
+ body = foldl (\map block -> Det.mapInsert (entryLabel block) block map) Det.mapEmpty $
blocks super
super = case labNodes cg of
[(_, s)] -> s
@@ -125,9 +127,9 @@ cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks
where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g)
cnodes = [(k, super block) | (k, block) <- blocks]
where super block = Nodes (entryLabel block) (Seq.singleton block)
- labelNumber = \lbl -> fromJust $ mapLookup lbl numbers
- where numbers :: LabelMap Int
- numbers = mapFromList $ map swap blocks
+ labelNumber = \lbl -> fromJust $ NonDet.mapLookup lbl numbers
+ where numbers :: NonDet.LabelMap Int
+ numbers = NonDet.mapFromList $ map swap blocks
swap (k, block) = (entryLabel block, k)
addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph
addSuccEdges graph (k, block) =
@@ -214,10 +216,10 @@ changeBlockLabels f block = blockJoin entry' middle exit'
relabel :: CmmSuper -> UniqDSM CmmSuper
relabel node = do
- finite_map <- foldM addPair mapEmpty $ definedLabels node
+ finite_map <- foldM addPair NonDet.mapEmpty $ definedLabels node
return $ changeLabels (labelChanger finite_map) node
- where addPair :: LabelMap Label -> Label -> UniqDSM (LabelMap Label)
+ where addPair :: NonDet.LabelMap Label -> Label -> UniqDSM (NonDet.LabelMap Label)
addPair map old = do new <- newBlockId
- return $ mapInsert old new map
- labelChanger :: LabelMap Label -> (Label -> Label)
- labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping
+ return $ NonDet.mapInsert old new map
+ labelChanger :: NonDet.LabelMap Label -> (Label -> Label)
+ labelChanger mapping = \lbl -> NonDet.mapFindWithDefault lbl lbl mapping
=====================================
compiler/GHC/Cmm/UniqueRenamer.hs
=====================================
@@ -17,7 +17,7 @@ import GHC.Cmm
import GHC.Cmm.CLabel
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
import GHC.Cmm.Switch
-- import GHC.Cmm.Info.Build
import GHC.Types.Unique
@@ -122,8 +122,8 @@ instance UniqRenamable LocalReg where
-- uniqRename (LocalReg uq t) = pure $ LocalReg uq t
-- ROMES:TODO: This has unique r1, we're debugging. this may still be a source of non determinism.
-instance UniqRenamable Label where
- uniqRename lbl = mkHooplLabel . getKey <$> renameDetUniq (getUnique lbl)
+instance UniqRenamable Det.Label where
+ uniqRename lbl = Det.mkHooplLabel . getKey <$> renameDetUniq (getUnique lbl)
instance UniqRenamable CmmTickScope where
-- ROMES:TODO: We may have to change this to get deterministic objects with ticks.
@@ -191,8 +191,8 @@ instance UniqRenamable CmmLit where
-- This is fine because LabelMap is backed by a deterministic UDFM
instance UniqRenamable a {- for 'Body' and on 'RawCmmStatics' -}
- => UniqRenamable (LabelMap a) where
- uniqRename lm = mapFromListWith panicMapKeysNotInjective <$> traverse (\(l,x) -> (,) <$> uniqRename l <*> uniqRename x) (mapToList lm)
+ => UniqRenamable (Det.LabelMap a) where
+ uniqRename lm = Det.mapFromListWith panicMapKeysNotInjective <$> traverse (\(l,x) -> (,) <$> uniqRename l <*> uniqRename x) (Det.mapToList lm)
instance UniqRenamable CmmGraph where
uniqRename (CmmGraph e g) = CmmGraph <$> uniqRename e <*> uniqRename g
=====================================
compiler/GHC/Cmm/Utils.hs
=====================================
@@ -84,7 +84,8 @@ import GHC.Platform.Regs
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Cmm.Dataflow.Block
---------------------------------------------------
@@ -515,19 +516,19 @@ mkLiveness platform (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)}
-ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
+ofBlockMap :: BlockId -> Det.LabelMap CmmBlock -> CmmGraph
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
-- | like 'toBlockList', but the entry block always comes first
toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
toBlockListEntryFirst g
- | mapNull m = []
+ | Det.mapNull m = []
| otherwise = entry_block : others
where
m = toBlockMap g
entry_id = g_entry g
- Just entry_block = mapLookup entry_id m
- others = filter ((/= entry_id) . entryLabel) (mapElems m)
+ Just entry_block = Det.mapLookup entry_id m
+ others = filter ((/= entry_id) . entryLabel) (Det.mapElems m)
-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks
-- so that the false case of a conditional jumps to the next block in the output
@@ -539,21 +540,21 @@ toBlockListEntryFirst g
-- defined in "GHC.Cmm.Node". -GBM
toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
toBlockListEntryFirstFalseFallthrough g
- | mapNull m = []
- | otherwise = dfs setEmpty [entry_block]
+ | Det.mapNull m = []
+ | otherwise = dfs NonDet.setEmpty [entry_block]
where
m = toBlockMap g
entry_id = g_entry g
- Just entry_block = mapLookup entry_id m
+ Just entry_block = Det.mapLookup entry_id m
- dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
+ dfs :: NonDet.LabelSet -> [CmmBlock] -> [CmmBlock]
dfs _ [] = []
dfs visited (block:bs)
- | id `setMember` visited = dfs visited bs
- | otherwise = block : dfs (setInsert id visited) bs'
+ | id `NonDet.setMember` visited = dfs visited bs
+ | otherwise = block : dfs (NonDet.setInsert id visited) bs'
where id = entryLabel block
bs' = foldr add_id bs (successors block)
- add_id id bs = case mapLookup id m of
+ add_id id bs = case Det.mapLookup id m of
Just b -> b : bs
Nothing -> bs
@@ -568,14 +569,14 @@ mapGraphNodes :: ( CmmNode C O -> CmmNode C O
-> CmmGraph -> CmmGraph
mapGraphNodes funs@(mf,_,_) g =
ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
- mapMap (mapBlock3' funs) $ toBlockMap g
+ Det.mapMap (mapBlock3' funs) $ toBlockMap g
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
mapGraphNodes1 f = modifyGraph (mapGraph f)
foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
-foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
+foldlGraphBlocks k z g = Det.mapFoldl k z $ toBlockMap g
-------------------------------------------------
-- Tick utilities
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -95,7 +95,7 @@ import GHC.Cmm.DebugBlock
import GHC.Cmm.BlockId
import GHC.StgToCmm.CgUtils ( fixStgRegisters )
import GHC.Cmm
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Cmm.GenericOpt
import GHC.Cmm.CLabel
@@ -166,7 +166,7 @@ data NativeGenAcc statics instr
-- required.
, ngs_colorStats :: ![[Color.RegAllocStats statics instr]]
, ngs_linearStats :: ![[Linear.RegAllocStats]]
- , ngs_labels :: ![Label]
+ , ngs_labels :: ![NonDet.Label]
, ngs_debug :: ![DebugBlock]
, ngs_dwarfFiles :: !DwarfFiles
, ngs_unwinds :: !(NonDet.LabelMap [UnwindPoint])
@@ -345,7 +345,7 @@ cmmNativeGens :: forall statics instr jumpDest.
-> NCGConfig
-> NcgImpl statics instr jumpDest
-> BufHandle
- -> LabelMap DebugBlock
+ -> NonDet.LabelMap DebugBlock
-> DUniqSupply
-> [RawCmmDecl]
-> NativeGenAcc statics instr
@@ -433,7 +433,7 @@ cmmNativeGen
-> NcgImpl statics instr jumpDest
-> DUniqSupply
-> DwarfFiles
- -> LabelMap DebugBlock
+ -> NonDet.LabelMap DebugBlock
-> RawCmmDecl -- ^ the cmm to generate code for
-> Int -- ^ sequence number of this top thing
-> IO ( DUniqSupply
@@ -660,7 +660,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
{-# SCC "invertCondBranches" #-}
map invert sequenced
where
- invertConds :: LabelMap RawCmmStatics -> [NatBasicBlock instr]
+ invertConds :: Det.LabelMap RawCmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
invertConds = invertCondBranches ncgImpl optimizedCFG
invert top at CmmData {} = top
@@ -700,18 +700,18 @@ maybeDumpCfg logger (Just cfg) msg proc_name
checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
-> Bool
checkLayout procsUnsequenced procsSequenced =
- assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff)
+ assertPpr (NonDet.setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff)
True
where
- blocks1 = foldl' (setUnion) setEmpty $
- map getBlockIds procsUnsequenced :: LabelSet
- blocks2 = foldl' (setUnion) setEmpty $
+ blocks1 = foldl' (NonDet.setUnion) NonDet.setEmpty $
+ map getBlockIds procsUnsequenced :: NonDet.LabelSet
+ blocks2 = foldl' (NonDet.setUnion) NonDet.setEmpty $
map getBlockIds procsSequenced
- diff = setDifference blocks1 blocks2
+ diff = NonDet.setDifference blocks1 blocks2
- getBlockIds (CmmData _ _) = setEmpty
+ getBlockIds (CmmData _ _) = NonDet.setEmpty
getBlockIds (CmmProc _ _ _ (ListGraph blocks)) =
- setFromList $ map blockId blocks
+ NonDet.setFromList $ map blockId blocks
-- | Compute unwinding tables for the blocks of a procedure
computeUnwinding :: Instruction instr
@@ -735,7 +735,7 @@ computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
-- information at the beginning of every block means that there is no need
-- to perform this sort of push-down.
NonDet.mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
- | BasicBlock blk_lbl instrs <- blks ]
+ | BasicBlock blk_lbl instrs <- blks ]
-- | Build a doc for all the imports.
--
@@ -842,8 +842,8 @@ shortcutBranches config ncgImpl tops weights
build_mapping :: forall instr t d statics jumpDest.
NcgImpl statics instr jumpDest
- -> GenCmmDecl d (LabelMap t) (ListGraph instr)
- -> (GenCmmDecl d (LabelMap t) (ListGraph instr)
+ -> GenCmmDecl d (Det.LabelMap t) (ListGraph instr)
+ -> (GenCmmDecl d (Det.LabelMap t) (ListGraph instr)
,NonDet.LabelMap jumpDest)
build_mapping _ top@(CmmData _ _) = (top, NonDet.mapEmpty)
build_mapping _ (CmmProc info lbl live (ListGraph []))
@@ -858,21 +858,21 @@ build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
-- Don't completely eliminate loops here -- that can leave a dangling jump!
shortcut_blocks :: [(BlockId, jumpDest)]
(_, shortcut_blocks, others) =
- foldl' split (setEmpty :: LabelSet, [], []) blocks
+ foldl' split (NonDet.setEmpty :: NonDet.LabelSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
| Just jd <- canShortcut ncgImpl insn
, Just dest <- getJumpDestBlockId ncgImpl jd
, not (has_info id)
- , (setMember dest s) || dest == id -- loop checks
+ , (NonDet.setMember dest s) || dest == id -- loop checks
= (s, shortcut_blocks, b : others)
split (s, shortcut_blocks, others) (BasicBlock id [insn])
| Just dest <- canShortcut ncgImpl insn
, not (has_info id)
- = (setInsert id s, (id,dest) : shortcut_blocks, others)
+ = (NonDet.setInsert id s, (id,dest) : shortcut_blocks, others)
split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
-- do not eliminate blocks that have an info table
- has_info l = mapMember l info
+ has_info l = Det.mapMember l info
-- build a mapping from BlockId to JumpDest for shorting branches
mapping = NonDet.mapFromList shortcut_blocks
@@ -918,7 +918,7 @@ genMachCode
:: NCGConfig
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
- -> LabelMap DebugBlock
+ -> NonDet.LabelMap DebugBlock
-> RawCmmDecl
-> CFG
-> UniqDSM
=====================================
compiler/GHC/CmmToAsm/CFG.hs
=====================================
@@ -48,7 +48,6 @@ import GHC.Cmm.BlockId
import GHC.Cmm as Cmm
import GHC.Cmm.Switch
---import GHC.Cmm.Dataflow.Label
import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import qualified GHC.Cmm.Dataflow.Label as Det
import GHC.Cmm.Dataflow.Block
=====================================
compiler/GHC/CmmToAsm/Monad.hs
=====================================
@@ -55,7 +55,8 @@ import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Types
import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Cmm.CLabel ( CLabel )
import GHC.Cmm.DebugBlock
import GHC.Cmm.Expr (LocalReg (..), isWord64)
@@ -112,14 +113,14 @@ data NcgImpl statics instr jumpDest = NcgImpl {
-> UniqDSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
-- ^ The list of block ids records the redirected jumps to allow us to update
-- the CFG.
- ncgMakeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
+ ncgMakeFarBranches :: Platform -> Det.LabelMap RawCmmStatics -> [NatBasicBlock instr]
-> UniqDSM [NatBasicBlock instr],
extractUnwindPoints :: [instr] -> [UnwindPoint],
-- ^ given the instruction sequence of a block, produce a list of
-- the block's 'UnwindPoint's
-- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
-- and Note [Unwinding information in the NCG] in this module.
- invertCondBranches :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
+ invertCondBranches :: Maybe CFG -> Det.LabelMap RawCmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
-- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@
-- when possible.
@@ -184,7 +185,7 @@ data NatM_State
natm_pic :: Maybe Reg,
natm_config :: NCGConfig,
natm_fileid :: DwarfFiles,
- natm_debug_map :: LabelMap DebugBlock,
+ natm_debug_map :: NonDet.LabelMap DebugBlock,
natm_cfg :: CFG
-- ^ Having a CFG with additional information is essential for some
-- operations. However we can't reconstruct all information once we
@@ -206,7 +207,7 @@ unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat (NatM a) = a
mkNatM_State :: DUniqSupply -> Int -> NCGConfig ->
- DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
+ DwarfFiles -> NonDet.LabelMap DebugBlock -> CFG -> NatM_State
mkNatM_State us delta config
= \dwf dbg cfg ->
NatM_State
@@ -364,5 +365,5 @@ getFileId f = NatM $ \st ->
fids = addToUFM (natm_fileid st) f (f,n)
in n `seq` fids `seq` (n, st { natm_fileid = fids })
-getDebugBlock :: Label -> NatM (Maybe DebugBlock)
-getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)
+getDebugBlock :: NonDet.Label -> NatM (Maybe DebugBlock)
+getDebugBlock l = NatM $ \st -> (NonDet.mapLookup l (natm_debug_map st), st)
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.CmmToAsm.Utils
import GHC.CmmToAsm.Ppr
import GHC.Cmm hiding (topInfoTable)
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.DebugBlock (pprUnwindTable)
@@ -161,7 +161,7 @@ pprSizeDecl platform lbl
then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)
else empty
-pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc
+pprBasicBlock :: IsDoc doc => NCGConfig -> Det.LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc
pprBasicBlock config info_env (BasicBlock blockid instrs)
= maybe_infotable $
pprLabel platform block_label $$
@@ -175,7 +175,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
where
block_label = blockLbl blockid
platform = ncgPlatform config
- maybe_infotable c = case mapLookup blockid info_env of
+ maybe_infotable c = case Det.mapLookup blockid info_env of
Nothing -> c
Just (CmmStaticsRaw infoLbl info) ->
pprAlignForSection platform Text $$
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -39,7 +39,7 @@ import GHC.Cmm.CLabel
import GHC.Cmm hiding (pprBBlock, pprStatic)
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.InitFini
@@ -78,7 +78,7 @@ cmmToC platform tops = (vcat $ intersperse blankLine $ map (pprTop platform) top
pprTop :: Platform -> RawCmmDecl -> SDoc
pprTop platform = \case
(CmmProc infos clbl _in_live_regs graph) ->
- (case mapLookup (g_entry graph) infos of
+ (case Det.mapLookup (g_entry graph) infos of
Nothing -> empty
Just (CmmStaticsRaw info_clbl info_dat) ->
pprDataExterns platform info_dat $$
=====================================
compiler/GHC/CmmToLlvm.hs
=====================================
@@ -25,7 +25,7 @@ import GHC.CmmToLlvm.Version
import GHC.StgToCmm.CgUtils ( fixStgRegisters )
import GHC.Cmm
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
import GHC.Utils.BufHandle
import GHC.Driver.DynFlags
@@ -135,7 +135,7 @@ llvmGroupLlvmGens cmm = do
let split (CmmData s d' ) = return $ Just (s, d')
split (CmmProc h l live g) = do
-- Set function type
- let l' = case mapLookup (g_entry g) h :: Maybe RawCmmStatics of
+ let l' = case Det.mapLookup (g_entry g) h :: Maybe RawCmmStatics of
Nothing -> l
Just (CmmStaticsRaw info_lbl _) -> info_lbl
lml <- strCLabel_llvm l'
=====================================
compiler/GHC/Wasm/ControlFlow/FromCmm.hs
=====================================
@@ -17,7 +17,8 @@ import GHC.Cmm
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dominators
import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
+import qualified GHC.Cmm.Dataflow.Label as Det
+import qualified GHC.Cmm.Dataflow.Label.NonDet as NonDet
import GHC.Cmm.Reducibility
import GHC.Cmm.Switch
@@ -57,12 +58,12 @@ to be found at https://www.cs.tufts.edu/~nr/pubs/relooper.pdf.
--
-- * Not at all.
-data ControlFlow e = Unconditional Label
- | Conditional e Label Label
+data ControlFlow e = Unconditional NonDet.Label
+ | Conditional e NonDet.Label NonDet.Label
| Switch { _scrutinee :: e
, _range :: BrTableInterval
- , _targets :: [Maybe Label] -- from 0
- , _defaultTarget :: Maybe Label
+ , _targets :: [Maybe NonDet.Label] -- from 0
+ , _defaultTarget :: Maybe NonDet.Label
}
| TailCall e
@@ -89,18 +90,18 @@ flowLeaving platform b =
-- reaches a given label.
data ContainingSyntax
- = BlockFollowedBy Label
- | LoopHeadedBy Label
- | IfThenElse (Maybe Label) -- ^ Carries the label that follows `if...end`, if any
+ = BlockFollowedBy NonDet.Label
+ | LoopHeadedBy NonDet.Label
+ | IfThenElse (Maybe NonDet.Label) -- ^ Carries the label that follows `if...end`, if any
-matchesFrame :: Label -> ContainingSyntax -> Bool
+matchesFrame :: NonDet.Label -> ContainingSyntax -> Bool
matchesFrame label (BlockFollowedBy l) = label == l
matchesFrame label (LoopHeadedBy l) = label == l
matchesFrame label (IfThenElse (Just l)) = label == l
matchesFrame _ _ = False
data Context = Context { enclosing :: [ContainingSyntax]
- , fallthrough :: Maybe Label -- the label can
+ , fallthrough :: Maybe NonDet.Label -- the label can
-- be reached just by "falling through"
-- the hole
}
@@ -114,7 +115,7 @@ emptyContext :: Context
emptyContext = Context [] Nothing
inside :: ContainingSyntax -> Context -> Context
-withFallthrough :: Context -> Label -> Context
+withFallthrough :: Context -> NonDet.Label -> Context
inside frame c = c { enclosing = frame : enclosing c }
withFallthrough c l = c { fallthrough = Just l }
@@ -140,8 +141,8 @@ emptyPost _ = False
structuredControl :: forall expr stmt m .
MonadUniqDSM m
=> Platform -- ^ needed for offset calculation
- -> (Label -> CmmExpr -> m expr) -- ^ translator for expressions
- -> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code
+ -> (NonDet.Label -> CmmExpr -> m expr) -- ^ translator for expressions
+ -> (NonDet.Label -> CmmActions -> m stmt) -- ^ translator for straight-line code
-> CmmGraph -- ^ CFG to be translated
-> m (WasmControl stmt expr '[] '[ 'I32])
structuredControl platform txExpr txBlock g' = do
@@ -158,9 +159,9 @@ structuredControl platform txExpr txBlock g' = do
doTree :: FT '[] post -> Tree.Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post)
nodeWithin :: forall post .
- FT '[] post -> CmmBlock -> [Tree.Tree CmmBlock] -> Maybe Label
+ FT '[] post -> CmmBlock -> [Tree.Tree CmmBlock] -> Maybe NonDet.Label
-> Context -> m (WasmControl stmt expr '[] post)
- doBranch :: FT '[] post -> Label -> Label -> Context -> m (WasmControl stmt expr '[] post)
+ doBranch :: FT '[] post -> NonDet.Label -> NonDet.Label -> Context -> m (WasmControl stmt expr '[] post)
doTree fty (Tree.Node x children) context =
let codeForX = nodeWithin fty x selectedChildren Nothing
@@ -206,7 +207,7 @@ structuredControl platform txExpr txBlock g' = do
<$~> range
<$~> map switchIndex targets
<$~> switchIndex default'
- where switchIndex :: Maybe Label -> Int
+ where switchIndex :: Maybe NonDet.Label -> Int
switchIndex Nothing = 0 -- arbitrary; GHC won't go here
switchIndex (Just lbl) = index lbl (enclosing context)
@@ -226,82 +227,82 @@ structuredControl platform txExpr txBlock g' = do
---- everything else is utility functions
- treeEntryLabel :: Tree.Tree CmmBlock -> Label
+ treeEntryLabel :: Tree.Tree CmmBlock -> NonDet.Label
treeEntryLabel = entryLabel . Tree.rootLabel
- sortTree :: Tree.Tree Label -> Tree.Tree Label
+ sortTree :: Tree.Tree NonDet.Label -> Tree.Tree NonDet.Label
-- Sort highest rpnum first
sortTree (Tree.Node label children) =
Tree.Node label $ sortBy (flip compare `on` (rpnum . Tree.rootLabel)) $
map sortTree children
- subtreeAt :: Label -> Tree.Tree CmmBlock
- blockLabeled :: Label -> CmmBlock
- rpnum :: Label -> RPNum-- reverse postorder number of the labeled block
- isMergeLabel :: Label -> Bool
+ subtreeAt :: NonDet.Label -> Tree.Tree CmmBlock
+ blockLabeled :: NonDet.Label -> CmmBlock
+ rpnum :: NonDet.Label -> RPNum-- reverse postorder number of the labeled block
+ isMergeLabel :: NonDet.Label -> Bool
isMergeNode :: CmmBlock -> Bool
isLoopHeader :: CmmBlock -> Bool-- identify loop headers
-- all nodes whose immediate dominator is the given block.
-- They are produced with the largest RP number first,
-- so the largest RP number is pushed on the context first.
- dominates :: Label -> Label -> Bool
+ dominates :: NonDet.Label -> NonDet.Label -> Bool
-- Domination relation (not just immediate domination)
- blockmap :: LabelMap CmmBlock
+ blockmap :: Det.LabelMap CmmBlock
GMany NothingO blockmap NothingO = g_graph g
- blockLabeled l = findLabelIn l blockmap
+ blockLabeled l = findLabelInDet l blockmap
rpblocks :: [CmmBlock]
rpblocks = revPostorderFrom blockmap (g_entry g)
- foldEdges :: forall a . (Label -> Label -> a -> a) -> a -> a
+ foldEdges :: forall a . (NonDet.Label -> NonDet.Label -> a -> a) -> a -> a
foldEdges f a =
foldl (\a (from, to) -> f from to a)
a
[(entryLabel from, to) | from <- rpblocks, to <- successors from]
- isMergeLabel l = setMember l mergeBlockLabels
+ isMergeLabel l = NonDet.setMember l mergeBlockLabels
isMergeNode = isMergeLabel . entryLabel
- isBackward :: Label -> Label -> Bool
+ isBackward :: NonDet.Label -> NonDet.Label -> Bool
isBackward from to = rpnum to <= rpnum from -- self-edge counts as a backward edge
subtreeAt label = findLabelIn label subtrees
- subtrees :: LabelMap (Tree.Tree CmmBlock)
- subtrees = addSubtree mapEmpty dominatorTree
+ subtrees :: NonDet.LabelMap (Tree.Tree CmmBlock)
+ subtrees = addSubtree NonDet.mapEmpty dominatorTree
where addSubtree map t@(Tree.Node root children) =
- foldl addSubtree (mapInsert (entryLabel root) t map) children
+ foldl addSubtree (NonDet.mapInsert (entryLabel root) t map) children
- mergeBlockLabels :: LabelSet
+ mergeBlockLabels :: NonDet.LabelSet
-- N.B. A block is a merge node if it is where control flow merges.
-- That means it is entered by multiple control-flow edges, _except_
-- back edges don't count. There must be multiple paths that enter the
-- block _without_ passing through the block itself.
mergeBlockLabels =
- setFromList [entryLabel n | n <- rpblocks, big (forwardPreds (entryLabel n))]
+ NonDet.setFromList [entryLabel n | n <- rpblocks, big (forwardPreds (entryLabel n))]
where big [] = False
big [_] = False
big (_ : _ : _) = True
- forwardPreds :: Label -> [Label] -- reachable predecessors of reachable blocks,
+ forwardPreds :: NonDet.Label -> [NonDet.Label] -- reachable predecessors of reachable blocks,
-- via forward edges only
- forwardPreds = \l -> mapFindWithDefault [] l predmap
- where predmap :: LabelMap [Label]
- predmap = foldEdges addForwardEdge mapEmpty
+ forwardPreds = \l -> NonDet.mapFindWithDefault [] l predmap
+ where predmap :: NonDet.LabelMap [NonDet.Label]
+ predmap = foldEdges addForwardEdge NonDet.mapEmpty
addForwardEdge from to pm
| isBackward from to = pm
| otherwise = addToList (from :) to pm
isLoopHeader = isHeaderLabel . entryLabel
- isHeaderLabel = (`setMember` headers) -- loop headers
- where headers :: LabelSet
+ isHeaderLabel = (`NonDet.setMember` headers) -- loop headers
+ where headers :: NonDet.LabelSet
headers = foldMap headersPointedTo blockmap
headersPointedTo block =
- setFromList [label | label <- successors block,
+ NonDet.setFromList [label | label <- successors block,
dominates label (entryLabel block)]
- index :: Label -> [ContainingSyntax] -> Int
+ index :: NonDet.Label -> [ContainingSyntax] -> Int
index _ [] = panic "destination label not in evaluation context"
index label (frame : context)
| label `matchesFrame` frame = 0
@@ -331,8 +332,8 @@ smartPlus platform e k =
CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger k) width)]
where width = cmmExprWidth platform e
-addToList :: ([a] -> [a]) -> Label -> LabelMap [a] -> LabelMap [a]
-addToList consx = mapAlter add
+addToList :: ([a] -> [a]) -> NonDet.Label -> NonDet.LabelMap [a] -> NonDet.LabelMap [a]
+addToList consx = NonDet.mapAlter add
where add Nothing = Just (consx [])
add (Just xs) = Just (consx xs)
@@ -344,8 +345,13 @@ instance Outputable ContainingSyntax where
ppr (LoopHeadedBy l) = text "loop" <+> ppr l
ppr (IfThenElse l) = text "if-then-else" <+> ppr l
-findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a
-findLabelIn lbl = mapFindWithDefault failed lbl
+findLabelInDet :: HasDebugCallStack => Det.Label -> Det.LabelMap a -> a
+findLabelInDet lbl = Det.mapFindWithDefault failed lbl
+ where failed =
+ pprPanic "label not found in control-flow graph" (ppr lbl)
+
+findLabelIn :: HasDebugCallStack => NonDet.Label -> NonDet.LabelMap a -> a
+findLabelIn lbl = NonDet.mapFindWithDefault failed lbl
where failed =
pprPanic "label not found in control-flow graph" (ppr lbl)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fef3e4362b0a35f1ca17b13a29e8132e974af6c3
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fef3e4362b0a35f1ca17b13a29e8132e974af6c3
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240712/025ebcdc/attachment-0001.html>
More information about the ghc-commits
mailing list