{-# LANGUAGE GADTs #-}
{-# LANGUAGE BangPatterns #-}
module GHC.Cmm.ContFlowOpt
( cmmCfgOpts
, cmmCfgOptsProc
, removeUnreachableBlocksProc
, replaceLabels
)
where
import GHC.Prelude hiding (succ, unzip, zip)
import GHC.Cmm.Dataflow.Block hiding (blockConcat)
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList)
import GHC.Data.Maybe
import GHC.Platform
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Control.Monad
cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts :: Bool -> GenCmmGraph CmmNode -> GenCmmGraph CmmNode
cmmCfgOpts Bool
split GenCmmGraph CmmNode
g = (GenCmmGraph CmmNode, LabelMap Label) -> GenCmmGraph CmmNode
forall a b. (a, b) -> a
fst (Bool
-> GenCmmGraph CmmNode -> (GenCmmGraph CmmNode, LabelMap Label)
blockConcat Bool
split GenCmmGraph CmmNode
g)
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc Bool
split (CmmProc CmmTopInfo
info CLabel
lbl [GlobalReg]
live GenCmmGraph CmmNode
g) = CmmTopInfo
-> CLabel -> [GlobalReg] -> GenCmmGraph CmmNode -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
info' CLabel
lbl [GlobalReg]
live GenCmmGraph CmmNode
g'
where (GenCmmGraph CmmNode
g', LabelMap Label
env) = Bool
-> GenCmmGraph CmmNode -> (GenCmmGraph CmmNode, LabelMap Label)
blockConcat Bool
split GenCmmGraph CmmNode
g
info' :: CmmTopInfo
info' = CmmTopInfo
info{ info_tbls = new_info_tbls }
new_info_tbls :: LabelMap CmmInfoTable
new_info_tbls = [(KeyOf LabelMap, CmmInfoTable)] -> LabelMap CmmInfoTable
forall a. [(KeyOf LabelMap, a)] -> LabelMap a
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList (((Label, CmmInfoTable) -> (Label, CmmInfoTable))
-> [(Label, CmmInfoTable)] -> [(Label, CmmInfoTable)]
forall a b. (a -> b) -> [a] -> [b]
map (Label, CmmInfoTable) -> (Label, CmmInfoTable)
upd_info (LabelMap CmmInfoTable -> [(KeyOf LabelMap, CmmInfoTable)]
forall a. LabelMap a -> [(KeyOf LabelMap, a)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
info)))
upd_info :: (Label, CmmInfoTable) -> (Label, CmmInfoTable)
upd_info (Label
k,CmmInfoTable
info)
| Just Label
k' <- KeyOf LabelMap -> LabelMap Label -> Maybe Label
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
k LabelMap Label
env
= (Label
k', if Label
k' Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== GenCmmGraph CmmNode -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry GenCmmGraph CmmNode
g'
then CmmInfoTable
info
else CmmInfoTable
info{ cit_lbl = infoTblLbl k' })
| Bool
otherwise
= (Label
k,CmmInfoTable
info)
cmmCfgOptsProc Bool
_ CmmDecl
top = CmmDecl
top
blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat :: Bool
-> GenCmmGraph CmmNode -> (GenCmmGraph CmmNode, LabelMap Label)
blockConcat Bool
splitting_procs g :: GenCmmGraph CmmNode
g@CmmGraph { g_entry :: forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry = Label
entry_id }
= (LabelMap Label -> GenCmmGraph CmmNode -> GenCmmGraph CmmNode
replaceLabels LabelMap Label
shortcut_map (GenCmmGraph CmmNode -> GenCmmGraph CmmNode)
-> GenCmmGraph CmmNode -> GenCmmGraph CmmNode
forall a b. (a -> b) -> a -> b
$ Label -> LabelMap CmmBlock -> GenCmmGraph CmmNode
ofBlockMap Label
new_entry LabelMap CmmBlock
new_blocks, LabelMap Label
shortcut_map')
where
(Label
new_entry, LabelMap Label
shortcut_map')
| Just CmmBlock
entry_blk <- KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
entry_id LabelMap CmmBlock
new_blocks
, Just Label
dest <- CmmBlock -> Maybe Label
canShortcut CmmBlock
entry_blk
= (Label
dest, KeyOf LabelMap -> Label -> LabelMap Label -> LabelMap Label
forall a. KeyOf LabelMap -> a -> LabelMap a -> LabelMap a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
entry_id Label
dest LabelMap Label
shortcut_map)
| Bool
otherwise
= (Label
entry_id, LabelMap Label
shortcut_map)
blocks :: [CmmBlock]
blocks = GenCmmGraph CmmNode -> [CmmBlock]
revPostorder GenCmmGraph CmmNode
g
blockmap :: LabelMap CmmBlock
blockmap = (LabelMap CmmBlock -> CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> [CmmBlock] -> LabelMap CmmBlock
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> CmmBlock -> LabelMap CmmBlock
forall a b c. (a -> b -> c) -> b -> a -> c
flip CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (block :: Extensibility -> Extensibility -> *).
(NonLocal block, HasDebugCallStack) =>
block 'Closed 'Closed
-> LabelMap (block 'Closed 'Closed)
-> LabelMap (block 'Closed 'Closed)
addBlock) LabelMap CmmBlock
forall (block :: (Extensibility -> Extensibility -> *)
-> Extensibility -> Extensibility -> *)
(n :: Extensibility -> Extensibility -> *).
Body' block n
emptyBody [CmmBlock]
blocks
(LabelMap CmmBlock
new_blocks, LabelMap Label
shortcut_map, LabelMap Int
_) =
(CmmBlock
-> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap Label, LabelMap Int))
-> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
-> [CmmBlock]
-> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmBlock
-> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
maybe_concat (LabelMap CmmBlock
blockmap, LabelMap Label
forall a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty, LabelMap Int
initialBackEdges) [CmmBlock]
blocks
initialBackEdges :: LabelMap Int
initialBackEdges = Label -> LabelMap Int -> LabelMap Int
incPreds Label
entry_id ([CmmBlock] -> LabelMap Int
predMap [CmmBlock]
blocks)
maybe_concat :: CmmBlock
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
maybe_concat :: CmmBlock
-> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap Label, LabelMap Int)
maybe_concat CmmBlock
block (!LabelMap CmmBlock
blocks, !LabelMap Label
shortcut_map, !LabelMap Int
backEdges)
| CmmBranch Label
b' <- CmmNode 'Open 'Closed
last
, Label -> Bool
hasOnePredecessor Label
b'
, Just CmmBlock
blk' <- KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
b' LabelMap CmmBlock
blocks
= let bid' :: Label
bid' = CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode 'Closed x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing 'Closed x -> Label
entryLabel CmmBlock
blk'
in ( KeyOf LabelMap -> LabelMap CmmBlock -> LabelMap CmmBlock
forall a. KeyOf LabelMap -> LabelMap a -> LabelMap a
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
Label
bid' (LabelMap CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> LabelMap CmmBlock
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall a. KeyOf LabelMap -> a -> LabelMap a -> LabelMap a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
bid (Block CmmNode 'Closed 'Open -> CmmBlock -> CmmBlock
splice Block CmmNode 'Closed 'Open
head CmmBlock
blk') LabelMap CmmBlock
blocks
, LabelMap Label
shortcut_map
, KeyOf LabelMap -> LabelMap Int -> LabelMap Int
forall a. KeyOf LabelMap -> LabelMap a -> LabelMap a
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
Label
b' LabelMap Int
backEdges )
| Bool
splitting_procs
, Just Label
b' <- CmmNode 'Open 'Closed -> Maybe Label
callContinuation_maybe CmmNode 'Open 'Closed
last
, Just CmmBlock
blk' <- KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
b' LabelMap CmmBlock
blocks
, Just Label
dest <- CmmBlock -> Maybe Label
canShortcut CmmBlock
blk'
= ( KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall a. KeyOf LabelMap -> a -> LabelMap a -> LabelMap a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
bid (Block CmmNode 'Closed 'Open -> CmmNode 'Open 'Closed -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e 'Open -> n 'Open 'Closed -> Block n e 'Closed
blockJoinTail Block CmmNode 'Closed 'Open
head (Label -> CmmNode 'Open 'Closed
update_cont Label
dest)) LabelMap CmmBlock
blocks
, KeyOf LabelMap -> Label -> LabelMap Label -> LabelMap Label
forall a. KeyOf LabelMap -> a -> LabelMap a -> LabelMap a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
b' Label
dest LabelMap Label
shortcut_map
, Label -> LabelMap Int -> LabelMap Int
decPreds Label
b' (LabelMap Int -> LabelMap Int) -> LabelMap Int -> LabelMap Int
forall a b. (a -> b) -> a -> b
$ Label -> LabelMap Int -> LabelMap Int
incPreds Label
dest LabelMap Int
backEdges )
| Maybe Label
Nothing <- CmmNode 'Open 'Closed -> Maybe Label
callContinuation_maybe CmmNode 'Open 'Closed
last
= let oldSuccs :: [Label]
oldSuccs = CmmNode 'Open 'Closed -> [Label]
forall (e :: Extensibility). CmmNode e 'Closed -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e 'Closed -> [Label]
successors CmmNode 'Open 'Closed
last
newSuccs :: [Label]
newSuccs = CmmNode 'Open 'Closed -> [Label]
forall (e :: Extensibility). CmmNode e 'Closed -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e 'Closed -> [Label]
successors CmmNode 'Open 'Closed
rewrite_last
in ( KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall a. KeyOf LabelMap -> a -> LabelMap a -> LabelMap a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
bid (Block CmmNode 'Closed 'Open -> CmmNode 'Open 'Closed -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e 'Open -> n 'Open 'Closed -> Block n e 'Closed
blockJoinTail Block CmmNode 'Closed 'Open
head CmmNode 'Open 'Closed
rewrite_last) LabelMap CmmBlock
blocks
, LabelMap Label
shortcut_map
, if [Label]
oldSuccs [Label] -> [Label] -> Bool
forall a. Eq a => a -> a -> Bool
== [Label]
newSuccs
then LabelMap Int
backEdges
else (Label -> LabelMap Int -> LabelMap Int)
-> LabelMap Int -> [Label] -> LabelMap Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Label -> LabelMap Int -> LabelMap Int
incPreds ((Label -> LabelMap Int -> LabelMap Int)
-> LabelMap Int -> [Label] -> LabelMap Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Label -> LabelMap Int -> LabelMap Int
decPreds LabelMap Int
backEdges [Label]
oldSuccs) [Label]
newSuccs )
| Bool
otherwise
= ( LabelMap CmmBlock
blocks, LabelMap Label
shortcut_map, LabelMap Int
backEdges )
where
(Block CmmNode 'Closed 'Open
head, CmmNode 'Open 'Closed
last) = CmmBlock -> (Block CmmNode 'Closed 'Open, CmmNode 'Open 'Closed)
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e 'Closed -> (Block n e 'Open, n 'Open 'Closed)
blockSplitTail CmmBlock
block
bid :: Label
bid = CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode 'Closed x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing 'Closed x -> Label
entryLabel CmmBlock
block
update_cont :: Label -> CmmNode 'Open 'Closed
update_cont Label
dest =
case CmmNode 'Open 'Closed
last of
CmmCall{} -> CmmNode 'Open 'Closed
last { cml_cont = Just dest }
CmmForeignCall{} -> CmmNode 'Open 'Closed
last { succ = dest }
CmmNode 'Open 'Closed
_ -> String -> CmmNode 'Open 'Closed
forall a. HasCallStack => String -> a
panic String
"Can't shortcut continuation."
shortcut_last :: CmmNode 'Open 'Closed
shortcut_last = (Label -> Label) -> CmmNode 'Open 'Closed -> CmmNode 'Open 'Closed
mapSuccessors Label -> Label
shortcut CmmNode 'Open 'Closed
last
where
shortcut :: Label -> Label
shortcut Label
l =
case KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
l LabelMap CmmBlock
blocks of
Just CmmBlock
b | Just Label
dest <- CmmBlock -> Maybe Label
canShortcut CmmBlock
b -> Label
dest
Maybe CmmBlock
_otherwise -> Label
l
rewrite_last :: CmmNode 'Open 'Closed
rewrite_last
| CmmCondBranch CmmExpr
_cond Label
t Label
f Maybe Bool
_l <- CmmNode 'Open 'Closed
shortcut_last
, Label
t Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
f
= Label -> CmmNode 'Open 'Closed
CmmBranch Label
t
| CmmCondBranch CmmExpr
cond Label
t Label
f Maybe Bool
l <- CmmNode 'Open 'Closed
shortcut_last
, Label -> Bool
hasOnePredecessor Label
t
, Maybe Bool -> Bool
likelyTrue Maybe Bool
l Bool -> Bool -> Bool
|| (Label -> Int
numPreds Label
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
, Just CmmExpr
cond' <- CmmExpr -> Maybe CmmExpr
maybeInvertCmmExpr CmmExpr
cond
= CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmExpr
cond' Label
f Label
t (Maybe Bool -> Maybe Bool
invertLikeliness Maybe Bool
l)
| CmmSwitch CmmExpr
_expr SwitchTargets
targets <- CmmNode 'Open 'Closed
shortcut_last
, (Label
t:[Label]
ts) <- SwitchTargets -> [Label]
switchTargetsToList SwitchTargets
targets
, (Label -> Bool) -> [Label] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
t) [Label]
ts
= Label -> CmmNode 'Open 'Closed
CmmBranch Label
t
| Bool
otherwise
= CmmNode 'Open 'Closed
shortcut_last
likelyTrue :: Maybe Bool -> Bool
likelyTrue (Just Bool
True) = Bool
True
likelyTrue Maybe Bool
_ = Bool
False
invertLikeliness :: Maybe Bool -> Maybe Bool
invertLikeliness :: Maybe Bool -> Maybe Bool
invertLikeliness = (Bool -> Bool) -> Maybe Bool -> Maybe Bool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not
numPreds :: Label -> Int
numPreds Label
bid = KeyOf LabelMap -> LabelMap Int -> Maybe Int
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
bid LabelMap Int
backEdges Maybe Int -> Int -> Int
forall a. Maybe a -> a -> a
`orElse` Int
0
hasOnePredecessor :: Label -> Bool
hasOnePredecessor Label
b = Label -> Int
numPreds Label
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int
incPreds :: Label -> LabelMap Int -> LabelMap Int
incPreds Label
bid LabelMap Int
edges = (Int -> Int -> Int)
-> KeyOf LabelMap -> Int -> LabelMap Int -> LabelMap Int
forall a.
(a -> a -> a) -> KeyOf LabelMap -> a -> LabelMap a -> LabelMap a
forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) KeyOf LabelMap
Label
bid Int
1 LabelMap Int
edges
decPreds :: Label -> LabelMap Int -> LabelMap Int
decPreds Label
bid LabelMap Int
edges = case KeyOf LabelMap -> LabelMap Int -> Maybe Int
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
bid LabelMap Int
edges of
Just Int
preds | Int
preds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> KeyOf LabelMap -> Int -> LabelMap Int -> LabelMap Int
forall a. KeyOf LabelMap -> a -> LabelMap a -> LabelMap a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
bid (Int
preds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) LabelMap Int
edges
Just Int
_ -> KeyOf LabelMap -> LabelMap Int -> LabelMap Int
forall a. KeyOf LabelMap -> LabelMap a -> LabelMap a
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
Label
bid LabelMap Int
edges
Maybe Int
_ -> LabelMap Int
edges
canShortcut :: CmmBlock -> Maybe BlockId
canShortcut :: CmmBlock -> Maybe Label
canShortcut CmmBlock
block
| (CmmNode 'Closed 'Open
_, Block CmmNode 'Open 'Open
middle, CmmBranch Label
dest) <- CmmBlock
-> (CmmNode 'Closed 'Open, Block CmmNode 'Open 'Open,
CmmNode 'Open 'Closed)
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Closed 'Closed
-> (n 'Closed 'Open, Block n 'Open 'Open, n 'Open 'Closed)
blockSplit CmmBlock
block
, (CmmNode 'Open 'Open -> Bool) -> [CmmNode 'Open 'Open] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CmmNode 'Open 'Open -> Bool
forall {e :: Extensibility} {x :: Extensibility}.
CmmNode e x -> Bool
dont_care ([CmmNode 'Open 'Open] -> Bool) -> [CmmNode 'Open 'Open] -> Bool
forall a b. (a -> b) -> a -> b
$ Block CmmNode 'Open 'Open -> [CmmNode 'Open 'Open]
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Open 'Open -> [n 'Open 'Open]
blockToList Block CmmNode 'Open 'Open
middle
= Label -> Maybe Label
forall a. a -> Maybe a
Just Label
dest
| Bool
otherwise
= Maybe Label
forall a. Maybe a
Nothing
where dont_care :: CmmNode e x -> Bool
dont_care CmmComment{} = Bool
True
dont_care CmmTick{} = Bool
True
dont_care CmmNode e x
_other = Bool
False
splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
splice :: Block CmmNode 'Closed 'Open -> CmmBlock -> CmmBlock
splice Block CmmNode 'Closed 'Open
head CmmBlock
rest = CmmNode 'Closed 'Open
entry CmmNode 'Closed 'Open
-> Block CmmNode 'Open 'Open -> Block CmmNode 'Closed 'Open
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n 'Closed 'Open -> Block n 'Open x -> Block n 'Closed x
`blockJoinHead` Block CmmNode 'Open 'Open
code0 Block CmmNode 'Closed 'Open
-> Block CmmNode 'Open 'Closed -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` Block CmmNode 'Open 'Closed
code1
where (CmmEntry Label
lbl CmmTickScope
sc0, Block CmmNode 'Open 'Open
code0) = Block CmmNode 'Closed 'Open
-> (CmmNode 'Closed 'Open, Block CmmNode 'Open 'Open)
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n 'Closed x -> (n 'Closed 'Open, Block n 'Open x)
blockSplitHead Block CmmNode 'Closed 'Open
head
(CmmEntry Label
_ CmmTickScope
sc1, Block CmmNode 'Open 'Closed
code1) = CmmBlock -> (CmmNode 'Closed 'Open, Block CmmNode 'Open 'Closed)
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n 'Closed x -> (n 'Closed 'Open, Block n 'Open x)
blockSplitHead CmmBlock
rest
entry :: CmmNode 'Closed 'Open
entry = Label -> CmmTickScope -> CmmNode 'Closed 'Open
CmmEntry Label
lbl (CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes CmmTickScope
sc0 CmmTickScope
sc1)
callContinuation_maybe :: CmmNode O C -> Maybe BlockId
callContinuation_maybe :: CmmNode 'Open 'Closed -> Maybe Label
callContinuation_maybe (CmmCall { cml_cont :: CmmNode 'Open 'Closed -> Maybe Label
cml_cont = Just Label
b }) = Label -> Maybe Label
forall a. a -> Maybe a
Just Label
b
callContinuation_maybe (CmmForeignCall { succ :: CmmNode 'Open 'Closed -> Label
succ = Label
b }) = Label -> Maybe Label
forall a. a -> Maybe a
Just Label
b
callContinuation_maybe CmmNode 'Open 'Closed
_ = Maybe Label
forall a. Maybe a
Nothing
replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels :: LabelMap Label -> GenCmmGraph CmmNode -> GenCmmGraph CmmNode
replaceLabels LabelMap Label
env GenCmmGraph CmmNode
g
| LabelMap Label -> Bool
forall a. LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap Label
env = GenCmmGraph CmmNode
g
| Bool
otherwise = GenCmmGraph CmmNode -> GenCmmGraph CmmNode
replace_eid (GenCmmGraph CmmNode -> GenCmmGraph CmmNode)
-> GenCmmGraph CmmNode -> GenCmmGraph CmmNode
forall a b. (a -> b) -> a -> b
$ (forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x)
-> GenCmmGraph CmmNode -> GenCmmGraph CmmNode
mapGraphNodes1 CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
txnode GenCmmGraph CmmNode
g
where
replace_eid :: GenCmmGraph CmmNode -> GenCmmGraph CmmNode
replace_eid GenCmmGraph CmmNode
g = GenCmmGraph CmmNode
g {g_entry = lookup (g_entry g)}
lookup :: Label -> Label
lookup Label
id = KeyOf LabelMap -> LabelMap Label -> Maybe Label
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
id LabelMap Label
env Maybe Label -> Label -> Label
forall a. Maybe a -> a -> a
`orElse` Label
id
txnode :: CmmNode e x -> CmmNode e x
txnode :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
txnode (CmmBranch Label
bid) = Label -> CmmNode 'Open 'Closed
CmmBranch (Label -> Label
lookup Label
bid)
txnode (CmmCondBranch CmmExpr
p Label
t Label
f Maybe Bool
l) =
CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
mkCmmCondBranch (CmmExpr -> CmmExpr
exp CmmExpr
p) (Label -> Label
lookup Label
t) (Label -> Label
lookup Label
f) Maybe Bool
l
txnode (CmmSwitch CmmExpr
e SwitchTargets
ids) =
CmmExpr -> SwitchTargets -> CmmNode 'Open 'Closed
CmmSwitch (CmmExpr -> CmmExpr
exp CmmExpr
e) ((Label -> Label) -> SwitchTargets -> SwitchTargets
mapSwitchTargets Label -> Label
lookup SwitchTargets
ids)
txnode (CmmCall CmmExpr
t Maybe Label
k [GlobalReg]
rg Int
a Int
res Int
r) =
CmmExpr
-> Maybe Label
-> [GlobalReg]
-> Int
-> Int
-> Int
-> CmmNode 'Open 'Closed
CmmCall (CmmExpr -> CmmExpr
exp CmmExpr
t) ((Label -> Label) -> Maybe Label -> Maybe Label
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Label -> Label
lookup Maybe Label
k) [GlobalReg]
rg Int
a Int
res Int
r
txnode fc :: CmmNode e x
fc@CmmForeignCall{} =
CmmNode e x
fc{ args = map exp (args fc), succ = lookup (succ fc) }
txnode CmmNode e x
other = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep CmmExpr -> CmmExpr
exp CmmNode e x
other
exp :: CmmExpr -> CmmExpr
exp :: CmmExpr -> CmmExpr
exp (CmmLit (CmmBlock Label
bid)) = CmmLit -> CmmExpr
CmmLit (Label -> CmmLit
CmmBlock (Label -> Label
lookup Label
bid))
exp (CmmStackSlot (Young Label
id) Int
i) = Area -> Int -> CmmExpr
CmmStackSlot (Label -> Area
Young (Label -> Label
lookup Label
id)) Int
i
exp CmmExpr
e = CmmExpr
e
mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
mkCmmCondBranch CmmExpr
p Label
t Label
f Maybe Bool
l =
if Label
t Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
f then Label -> CmmNode 'Open 'Closed
CmmBranch Label
t else CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode 'Open 'Closed
CmmCondBranch CmmExpr
p Label
t Label
f Maybe Bool
l
predMap :: [CmmBlock] -> LabelMap Int
predMap :: [CmmBlock] -> LabelMap Int
predMap [CmmBlock]
blocks = (CmmBlock -> LabelMap Int -> LabelMap Int)
-> LabelMap Int -> [CmmBlock] -> LabelMap Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmBlock -> LabelMap Int -> LabelMap Int
forall {map :: * -> *} {a}
{thing :: Extensibility -> Extensibility -> *}
{e :: Extensibility}.
(KeyOf map ~ Label, IsMap map, Num a, NonLocal thing) =>
thing e 'Closed -> map a -> map a
add_preds LabelMap Int
forall a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [CmmBlock]
blocks
where
add_preds :: thing e 'Closed -> map a -> map a
add_preds thing e 'Closed
block map a
env = (Label -> map a -> map a) -> map a -> [Label] -> map a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr KeyOf map -> map a -> map a
Label -> map a -> map a
forall {map :: * -> *} {a}.
(IsMap map, Num a) =>
KeyOf map -> map a -> map a
add map a
env (thing e 'Closed -> [Label]
forall (e :: Extensibility). thing e 'Closed -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e 'Closed -> [Label]
successors thing e 'Closed
block)
where add :: KeyOf map -> map a -> map a
add KeyOf map
lbl map a
env = (a -> a -> a) -> KeyOf map -> a -> map a -> map a
forall a. (a -> a -> a) -> KeyOf map -> a -> map a -> map a
forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith a -> a -> a
forall a. Num a => a -> a -> a
(+) KeyOf map
lbl a
1 map a
env
removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl
removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl
removeUnreachableBlocksProc Platform
_ proc :: CmmDecl
proc@(CmmProc CmmTopInfo
info CLabel
lbl [GlobalReg]
live GenCmmGraph CmmNode
g)
| [CmmBlock]
used_blocks [CmmBlock] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthLessThan` LabelMap CmmBlock -> Int
forall a. LabelMap a -> Int
forall (map :: * -> *) a. IsMap map => map a -> Int
mapSize (GenCmmGraph CmmNode -> LabelMap CmmBlock
toBlockMap GenCmmGraph CmmNode
g)
= CmmTopInfo
-> CLabel -> [GlobalReg] -> GenCmmGraph CmmNode -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
info' CLabel
lbl [GlobalReg]
live GenCmmGraph CmmNode
g'
| Bool
otherwise
= CmmDecl
proc
where
g' :: GenCmmGraph CmmNode
g' = Label -> [CmmBlock] -> GenCmmGraph CmmNode
ofBlockList (GenCmmGraph CmmNode -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry GenCmmGraph CmmNode
g) [CmmBlock]
used_blocks
info' :: CmmTopInfo
info' = CmmTopInfo
info { info_tbls = keep_used (info_tbls info) }
keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
keep_used LabelMap CmmInfoTable
bs = (LabelMap CmmInfoTable
-> KeyOf LabelMap -> CmmInfoTable -> LabelMap CmmInfoTable)
-> LabelMap CmmInfoTable
-> LabelMap CmmInfoTable
-> LabelMap CmmInfoTable
forall b a. (b -> KeyOf LabelMap -> a -> b) -> b -> LabelMap a -> b
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey LabelMap CmmInfoTable
-> KeyOf LabelMap -> CmmInfoTable -> LabelMap CmmInfoTable
LabelMap CmmInfoTable
-> Label -> CmmInfoTable -> LabelMap CmmInfoTable
keep LabelMap CmmInfoTable
forall a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty LabelMap CmmInfoTable
bs
keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
keep :: LabelMap CmmInfoTable
-> Label -> CmmInfoTable -> LabelMap CmmInfoTable
keep LabelMap CmmInfoTable
env Label
l CmmInfoTable
i | ElemOf LabelSet
Label
l ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` LabelSet
used_lbls = KeyOf LabelMap
-> CmmInfoTable -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall a. KeyOf LabelMap -> a -> LabelMap a -> LabelMap a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
Label
l CmmInfoTable
i LabelMap CmmInfoTable
env
| Bool
otherwise = LabelMap CmmInfoTable
env
used_blocks :: [CmmBlock]
used_blocks :: [CmmBlock]
used_blocks = GenCmmGraph CmmNode -> [CmmBlock]
revPostorder GenCmmGraph CmmNode
g
used_lbls :: LabelSet
used_lbls :: LabelSet
used_lbls = [ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList ([ElemOf LabelSet] -> LabelSet) -> [ElemOf LabelSet] -> LabelSet
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> Label) -> [CmmBlock] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode 'Closed x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing 'Closed x -> Label
entryLabel [CmmBlock]
used_blocks
removeUnreachableBlocksProc Platform
platform data' :: CmmDecl
data'@(CmmData Section
_ GenCmmStatics 'False
_) =
String -> SDoc -> CmmDecl
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"removeUnreachableBlocksProc: passed data declaration instead of procedure" (Platform -> CmmDecl -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmDecl
data')