{-# LANGUAGE GADTs #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module CmmContFlowOpt
( cmmCfgOpts
, cmmCfgOptsProc
, removeUnreachableBlocksProc
, replaceLabels
)
where
import GhcPrelude hiding (succ, unzip, zip)
import Hoopl.Block
import Hoopl.Collections
import Hoopl.Graph
import Hoopl.Label
import BlockId
import Cmm
import CmmUtils
import CmmSwitch (mapSwitchTargets, switchTargetsToList)
import Maybes
import Panic
import Util
import Control.Monad
cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts Bool
split CmmGraph
g = (CmmGraph, LabelMap BlockId) -> CmmGraph
forall a b. (a, b) -> a
fst (Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat Bool
split CmmGraph
g)
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc Bool
split (CmmProc CmmTopInfo
info CLabel
lbl [GlobalReg]
live CmmGraph
g) = CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
info' CLabel
lbl [GlobalReg]
live CmmGraph
g'
where (CmmGraph
g', LabelMap BlockId
env) = Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat Bool
split CmmGraph
g
info' :: CmmTopInfo
info' = CmmTopInfo
info{ info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
new_info_tbls }
new_info_tbls :: LabelMap CmmInfoTable
new_info_tbls = [(KeyOf LabelMap, CmmInfoTable)] -> LabelMap CmmInfoTable
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList (((BlockId, CmmInfoTable) -> (BlockId, CmmInfoTable))
-> [(BlockId, CmmInfoTable)] -> [(BlockId, CmmInfoTable)]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, CmmInfoTable) -> (BlockId, CmmInfoTable)
upd_info (LabelMap CmmInfoTable -> [(KeyOf LabelMap, CmmInfoTable)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
info)))
upd_info :: (BlockId, CmmInfoTable) -> (BlockId, CmmInfoTable)
upd_info (BlockId
k,CmmInfoTable
info)
| Just BlockId
k' <- KeyOf LabelMap -> LabelMap BlockId -> Maybe BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
k LabelMap BlockId
env
= (BlockId
k', if BlockId
k' BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g'
then CmmInfoTable
info
else CmmInfoTable
info{ cit_lbl :: CLabel
cit_lbl = BlockId -> CLabel
infoTblLbl BlockId
k' })
| Bool
otherwise
= (BlockId
k,CmmInfoTable
info)
cmmCfgOptsProc Bool
_ CmmDecl
top = CmmDecl
top
blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
blockConcat Bool
splitting_procs g :: CmmGraph
g@CmmGraph { g_entry :: forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry = BlockId
entry_id }
= (LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels LabelMap BlockId
shortcut_map (CmmGraph -> CmmGraph) -> CmmGraph -> CmmGraph
forall a b. (a -> b) -> a -> b
$ BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap BlockId
new_entry LabelMap CmmBlock
new_blocks, LabelMap BlockId
shortcut_map')
where
(BlockId
new_entry, LabelMap BlockId
shortcut_map')
| Just CmmBlock
entry_blk <- KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
entry_id LabelMap CmmBlock
new_blocks
, Just BlockId
dest <- CmmBlock -> Maybe BlockId
canShortcut CmmBlock
entry_blk
= (BlockId
dest, KeyOf LabelMap -> BlockId -> LabelMap BlockId -> LabelMap BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
entry_id BlockId
dest LabelMap BlockId
shortcut_map)
| Bool
otherwise
= (BlockId
entry_id, LabelMap BlockId
shortcut_map)
blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
g
blockmap :: LabelMap CmmBlock
blockmap = (LabelMap CmmBlock -> CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> [CmmBlock] -> LabelMap CmmBlock
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 C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock) LabelMap CmmBlock
forall (block :: (Extensibility -> Extensibility -> *)
-> Extensibility -> Extensibility -> *)
(n :: Extensibility -> Extensibility -> *).
Body' block n
emptyBody [CmmBlock]
blocks
(LabelMap CmmBlock
new_blocks, LabelMap BlockId
shortcut_map, LabelMap Int
_) =
(CmmBlock
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int))
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-> [CmmBlock]
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmBlock
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
maybe_concat (LabelMap CmmBlock
blockmap, LabelMap BlockId
forall (map :: * -> *) a. IsMap map => map a
mapEmpty, LabelMap Int
initialBackEdges) [CmmBlock]
blocks
initialBackEdges :: LabelMap Int
initialBackEdges = BlockId -> LabelMap Int -> LabelMap Int
incPreds BlockId
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 BlockId, LabelMap Int)
-> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
maybe_concat CmmBlock
block (!LabelMap CmmBlock
blocks, !LabelMap BlockId
shortcut_map, !LabelMap Int
backEdges)
| CmmBranch BlockId
b' <- CmmNode O C
last
, BlockId -> Bool
hasOnePredecessor BlockId
b'
, Just CmmBlock
blk' <- KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
b' LabelMap CmmBlock
blocks
= let bid' :: BlockId
bid' = CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
blk'
in ( KeyOf LabelMap -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
bid' (LabelMap CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> LabelMap CmmBlock
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
bid (Block CmmNode C O -> CmmBlock -> CmmBlock
splice Block CmmNode C O
head CmmBlock
blk') LabelMap CmmBlock
blocks
, LabelMap BlockId
shortcut_map
, KeyOf LabelMap -> LabelMap Int -> LabelMap Int
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
b' LabelMap Int
backEdges )
| Bool
splitting_procs
, Just BlockId
b' <- CmmNode O C -> Maybe BlockId
callContinuation_maybe CmmNode O C
last
, Just CmmBlock
blk' <- KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
b' LabelMap CmmBlock
blocks
, Just BlockId
dest <- CmmBlock -> Maybe BlockId
canShortcut CmmBlock
blk'
= ( KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
bid (Block CmmNode C O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
head (BlockId -> CmmNode O C
update_cont BlockId
dest)) LabelMap CmmBlock
blocks
, KeyOf LabelMap -> BlockId -> LabelMap BlockId -> LabelMap BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
b' BlockId
dest LabelMap BlockId
shortcut_map
, BlockId -> LabelMap Int -> LabelMap Int
decPreds BlockId
b' (LabelMap Int -> LabelMap Int) -> LabelMap Int -> LabelMap Int
forall a b. (a -> b) -> a -> b
$ BlockId -> LabelMap Int -> LabelMap Int
incPreds BlockId
dest LabelMap Int
backEdges )
| Maybe BlockId
Nothing <- CmmNode O C -> Maybe BlockId
callContinuation_maybe CmmNode O C
last
= let oldSuccs :: [BlockId]
oldSuccs = CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last
newSuccs :: [BlockId]
newSuccs = CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
rewrite_last
in ( KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
bid (Block CmmNode C O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
head CmmNode O C
rewrite_last) LabelMap CmmBlock
blocks
, LabelMap BlockId
shortcut_map
, if [BlockId]
oldSuccs [BlockId] -> [BlockId] -> Bool
forall a. Eq a => a -> a -> Bool
== [BlockId]
newSuccs
then LabelMap Int
backEdges
else (BlockId -> LabelMap Int -> LabelMap Int)
-> LabelMap Int -> [BlockId] -> LabelMap Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BlockId -> LabelMap Int -> LabelMap Int
incPreds ((BlockId -> LabelMap Int -> LabelMap Int)
-> LabelMap Int -> [BlockId] -> LabelMap Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BlockId -> LabelMap Int -> LabelMap Int
decPreds LabelMap Int
backEdges [BlockId]
oldSuccs) [BlockId]
newSuccs )
| Bool
otherwise
= ( LabelMap CmmBlock
blocks, LabelMap BlockId
shortcut_map, LabelMap Int
backEdges )
where
(Block CmmNode C O
head, CmmNode O C
last) = CmmBlock -> (Block CmmNode C O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e C -> (Block n e O, n O C)
blockSplitTail CmmBlock
block
bid :: BlockId
bid = CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block
update_cont :: BlockId -> CmmNode O C
update_cont BlockId
dest =
case CmmNode O C
last of
CmmCall{} -> CmmNode O C
last { cml_cont :: Maybe BlockId
cml_cont = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
dest }
CmmForeignCall{} -> CmmNode O C
last { succ :: BlockId
succ = BlockId
dest }
CmmNode O C
_ -> String -> CmmNode O C
forall a. String -> a
panic String
"Can't shortcut continuation."
shortcut_last :: CmmNode O C
shortcut_last = (BlockId -> BlockId) -> CmmNode O C -> CmmNode O C
mapSuccessors BlockId -> BlockId
shortcut CmmNode O C
last
where
shortcut :: BlockId -> BlockId
shortcut BlockId
l =
case KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l LabelMap CmmBlock
blocks of
Just CmmBlock
b | Just BlockId
dest <- CmmBlock -> Maybe BlockId
canShortcut CmmBlock
b -> BlockId
dest
Maybe CmmBlock
_otherwise -> BlockId
l
rewrite_last :: CmmNode O C
rewrite_last
| CmmCondBranch CmmExpr
_cond BlockId
t BlockId
f Maybe Bool
_l <- CmmNode O C
shortcut_last
, BlockId
t BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
f
= BlockId -> CmmNode O C
CmmBranch BlockId
t
| CmmCondBranch CmmExpr
cond BlockId
t BlockId
f Maybe Bool
l <- CmmNode O C
shortcut_last
, BlockId -> Bool
hasOnePredecessor BlockId
t
, Maybe Bool -> Bool
likelyTrue Maybe Bool
l Bool -> Bool -> Bool
|| (BlockId -> Int
numPreds BlockId
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
, Just CmmExpr
cond' <- CmmExpr -> Maybe CmmExpr
maybeInvertCmmExpr CmmExpr
cond
= CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
cond' BlockId
f BlockId
t (Maybe Bool -> Maybe Bool
invertLikeliness Maybe Bool
l)
| CmmSwitch CmmExpr
_expr SwitchTargets
targets <- CmmNode O C
shortcut_last
, (BlockId
t:[BlockId]
ts) <- SwitchTargets -> [BlockId]
switchTargetsToList SwitchTargets
targets
, (BlockId -> Bool) -> [BlockId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
t) [BlockId]
ts
= BlockId -> CmmNode O C
CmmBranch BlockId
t
| Bool
otherwise
= CmmNode O C
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not
numPreds :: BlockId -> Int
numPreds BlockId
bid = KeyOf LabelMap -> LabelMap Int -> Maybe Int
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid LabelMap Int
backEdges Maybe Int -> Int -> Int
forall a. Maybe a -> a -> a
`orElse` Int
0
hasOnePredecessor :: BlockId -> Bool
hasOnePredecessor BlockId
b = BlockId -> Int
numPreds BlockId
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int
incPreds :: BlockId -> LabelMap Int -> LabelMap Int
incPreds BlockId
bid LabelMap Int
edges = (Int -> Int -> Int)
-> KeyOf LabelMap -> Int -> LabelMap Int -> LabelMap Int
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
BlockId
bid Int
1 LabelMap Int
edges
decPreds :: BlockId -> LabelMap Int -> LabelMap Int
decPreds BlockId
bid LabelMap Int
edges = case KeyOf LabelMap -> LabelMap Int -> Maybe Int
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
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 (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
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 (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
bid LabelMap Int
edges
Maybe Int
_ -> LabelMap Int
edges
canShortcut :: CmmBlock -> Maybe BlockId
canShortcut :: CmmBlock -> Maybe BlockId
canShortcut CmmBlock
block
| (CmmNode C O
_, Block CmmNode O O
middle, CmmBranch BlockId
dest) <- CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
, (CmmNode O O -> Bool) -> [CmmNode O O] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CmmNode O O -> Bool
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Bool
dont_care ([CmmNode O O] -> Bool) -> [CmmNode O O] -> Bool
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
middle
= BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
dest
| Bool
otherwise
= Maybe BlockId
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 C O -> CmmBlock -> CmmBlock
splice Block CmmNode C O
head CmmBlock
rest = CmmNode C O
entry CmmNode C O -> Block CmmNode O O -> Block CmmNode C O
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n C O -> Block n O x -> Block n C x
`blockJoinHead` Block CmmNode O O
code0 Block CmmNode C O -> Block CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility) (x :: Extensibility).
Block n e O -> Block n O x -> Block n e x
`blockAppend` Block CmmNode O C
code1
where (CmmEntry BlockId
lbl CmmTickScope
sc0, Block CmmNode O O
code0) = Block CmmNode C O -> (CmmNode C O, Block CmmNode O O)
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n C x -> (n C O, Block n O x)
blockSplitHead Block CmmNode C O
head
(CmmEntry BlockId
_ CmmTickScope
sc1, Block CmmNode O C
code1) = CmmBlock -> (CmmNode C O, Block CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n C x -> (n C O, Block n O x)
blockSplitHead CmmBlock
rest
entry :: CmmNode C O
entry = BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
lbl (CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes CmmTickScope
sc0 CmmTickScope
sc1)
callContinuation_maybe :: CmmNode O C -> Maybe BlockId
callContinuation_maybe :: CmmNode O C -> Maybe BlockId
callContinuation_maybe (CmmCall { cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just BlockId
b }) = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
b
callContinuation_maybe (CmmForeignCall { succ :: CmmNode O C -> BlockId
succ = BlockId
b }) = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
b
callContinuation_maybe CmmNode O C
_ = Maybe BlockId
forall a. Maybe a
Nothing
replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceLabels LabelMap BlockId
env CmmGraph
g
| LabelMap BlockId -> Bool
forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap BlockId
env = CmmGraph
g
| Bool
otherwise = CmmGraph -> CmmGraph
replace_eid (CmmGraph -> CmmGraph) -> CmmGraph -> CmmGraph
forall a b. (a -> b) -> a -> b
$ (forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x)
-> CmmGraph -> CmmGraph
mapGraphNodes1 forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
txnode CmmGraph
g
where
replace_eid :: CmmGraph -> CmmGraph
replace_eid CmmGraph
g = CmmGraph
g {g_entry :: BlockId
g_entry = BlockId -> BlockId
lookup (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g)}
lookup :: BlockId -> BlockId
lookup BlockId
id = KeyOf LabelMap -> LabelMap BlockId -> Maybe BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
id LabelMap BlockId
env Maybe BlockId -> BlockId -> BlockId
forall a. Maybe a -> a -> a
`orElse` BlockId
id
txnode :: CmmNode e x -> CmmNode e x
txnode :: CmmNode e x -> CmmNode e x
txnode (CmmBranch BlockId
bid) = BlockId -> CmmNode O C
CmmBranch (BlockId -> BlockId
lookup BlockId
bid)
txnode (CmmCondBranch CmmExpr
p BlockId
t BlockId
f Maybe Bool
l) =
CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
mkCmmCondBranch (CmmExpr -> CmmExpr
exp CmmExpr
p) (BlockId -> BlockId
lookup BlockId
t) (BlockId -> BlockId
lookup BlockId
f) Maybe Bool
l
txnode (CmmSwitch CmmExpr
e SwitchTargets
ids) =
CmmExpr -> SwitchTargets -> CmmNode O C
CmmSwitch (CmmExpr -> CmmExpr
exp CmmExpr
e) ((BlockId -> BlockId) -> SwitchTargets -> SwitchTargets
mapSwitchTargets BlockId -> BlockId
lookup SwitchTargets
ids)
txnode (CmmCall CmmExpr
t Maybe BlockId
k [GlobalReg]
rg Int
a Int
res Int
r) =
CmmExpr
-> Maybe BlockId -> [GlobalReg] -> Int -> Int -> Int -> CmmNode O C
CmmCall (CmmExpr -> CmmExpr
exp CmmExpr
t) ((BlockId -> BlockId) -> Maybe BlockId -> Maybe BlockId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM BlockId -> BlockId
lookup Maybe BlockId
k) [GlobalReg]
rg Int
a Int
res Int
r
txnode fc :: CmmNode e x
fc@CmmForeignCall{} =
CmmNode e x
fc{ args :: [CmmExpr]
args = (CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map CmmExpr -> CmmExpr
exp (CmmNode O C -> [CmmExpr]
args CmmNode e x
CmmNode O C
fc), succ :: BlockId
succ = BlockId -> BlockId
lookup (CmmNode O C -> BlockId
succ CmmNode e x
CmmNode O C
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 BlockId
bid)) = CmmLit -> CmmExpr
CmmLit (BlockId -> CmmLit
CmmBlock (BlockId -> BlockId
lookup BlockId
bid))
exp (CmmStackSlot (Young BlockId
id) Int
i) = Area -> Int -> CmmExpr
CmmStackSlot (BlockId -> Area
Young (BlockId -> BlockId
lookup BlockId
id)) Int
i
exp CmmExpr
e = CmmExpr
e
mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
mkCmmCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
mkCmmCondBranch CmmExpr
p BlockId
t BlockId
f Maybe Bool
l =
if BlockId
t BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
f then BlockId -> CmmNode O C
CmmBranch BlockId
t else CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
p BlockId
t BlockId
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 (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).
(IsMap map, Num a, NonLocal thing, KeyOf map ~ BlockId) =>
thing e C -> map a -> map a
add_preds LabelMap Int
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [CmmBlock]
blocks
where
add_preds :: thing e C -> map a -> map a
add_preds thing e C
block map a
env = (BlockId -> map a -> map a) -> map a -> [BlockId] -> map a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BlockId -> map a -> map a
forall (map :: * -> *) a.
(IsMap map, Num a) =>
KeyOf map -> map a -> map a
add map a
env (thing e C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors thing e C
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 (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 :: CmmDecl -> CmmDecl
removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
removeUnreachableBlocksProc proc :: CmmDecl
proc@(CmmProc CmmTopInfo
info CLabel
lbl [GlobalReg]
live CmmGraph
g)
| [CmmBlock]
used_blocks [CmmBlock] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthLessThan` LabelMap CmmBlock -> Int
forall (map :: * -> *) a. IsMap map => map a -> Int
mapSize (CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g)
= CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
info' CLabel
lbl [GlobalReg]
live CmmGraph
g'
| Bool
otherwise
= CmmDecl
proc
where
g' :: CmmGraph
g' = BlockId -> [CmmBlock] -> CmmGraph
ofBlockList (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g) [CmmBlock]
used_blocks
info' :: CmmTopInfo
info' = CmmTopInfo
info { info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable -> LabelMap CmmInfoTable
keep_used (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
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 (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey LabelMap CmmInfoTable
-> KeyOf LabelMap -> CmmInfoTable -> LabelMap CmmInfoTable
LabelMap CmmInfoTable
-> BlockId -> CmmInfoTable -> LabelMap CmmInfoTable
keep LabelMap CmmInfoTable
forall (map :: * -> *) a. IsMap map => map a
mapEmpty LabelMap CmmInfoTable
bs
keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
keep :: LabelMap CmmInfoTable
-> BlockId -> CmmInfoTable -> LabelMap CmmInfoTable
keep LabelMap CmmInfoTable
env BlockId
l CmmInfoTable
i | ElemOf LabelSet
BlockId
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 (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
l CmmInfoTable
i LabelMap CmmInfoTable
env
| Bool
otherwise = LabelMap CmmInfoTable
env
used_blocks :: [CmmBlock]
used_blocks :: [CmmBlock]
used_blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
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 -> BlockId) -> [CmmBlock] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel [CmmBlock]
used_blocks