module CmmContFlowOpt
( cmmCfgOpts
, cmmCfgOptsProc
, removeUnreachableBlocks
, replaceLabels
)
where
import BlockId
import Cmm
import CmmUtils
import Maybes
import Hoopl
import Control.Monad
import Prelude hiding (succ, unzip, zip)
cmmCfgOpts :: CmmGraph -> CmmGraph
cmmCfgOpts = removeUnreachableBlocks . blockConcat
cmmCfgOptsProc :: CmmDecl -> CmmDecl
cmmCfgOptsProc = optProc cmmCfgOpts
optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
optProc _ top = top
blockConcat :: CmmGraph -> CmmGraph
blockConcat g@CmmGraph { g_entry = entry_id }
= replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks
where
new_entry
| Just entry_blk <- mapLookup entry_id new_blocks
, Just dest <- canShortcut entry_blk
= dest
| otherwise
= entry_id
blocks = postorderDfs g
(new_blocks, shortcut_map) =
foldr maybe_concat (toBlockMap g, mapEmpty) blocks
maybe_concat :: CmmBlock
-> (BlockEnv CmmBlock, BlockEnv BlockId)
-> (BlockEnv CmmBlock, BlockEnv BlockId)
maybe_concat block (blocks, shortcut_map)
| CmmBranch b' <- last
, Just blk' <- mapLookup b' blocks
, shouldConcatWith b' blk'
= (mapInsert bid (splice head blk') blocks, shortcut_map)
| Just b' <- callContinuation_maybe last
, Just blk' <- mapLookup b' blocks
, Just dest <- canShortcut blk'
= (blocks, mapInsert b' dest shortcut_map)
| Nothing <- callContinuation_maybe last
= ( mapInsert bid (blockJoinTail head shortcut_last) blocks
, shortcut_map )
| otherwise
= (blocks, shortcut_map)
where
(head, last) = blockSplitTail block
bid = entryLabel block
shortcut_last = mapSuccessors shortcut last
shortcut l =
case mapLookup l blocks of
Just b | Just dest <- canShortcut b -> dest
_otherwise -> l
shouldConcatWith b block
| num_preds b == 1 = True
| okToDuplicate block = True
| otherwise = False
where num_preds bid = mapLookup bid backEdges `orElse` 0
canShortcut :: CmmBlock -> Maybe BlockId
canShortcut block
| (_, middle, CmmBranch dest) <- blockSplit block
, isEmptyBlock middle
= Just dest
| otherwise
= Nothing
backEdges :: BlockEnv Int
backEdges = mapInsertWith (+) entry_id 1 $
mapMap setSize $ predMap blocks
splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
splice head rest = head `blockAppend` snd (blockSplitHead rest)
callContinuation_maybe :: CmmNode O C -> Maybe BlockId
callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
callContinuation_maybe (CmmForeignCall { succ = b }) = Just b
callContinuation_maybe _ = Nothing
okToDuplicate :: CmmBlock -> Bool
okToDuplicate block
= case blockSplit block of
(_, m, CmmBranch _) -> isEmptyBlock m
_otherwise -> False
replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceLabels env g
| 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
txnode :: CmmNode e x -> CmmNode e x
txnode (CmmBranch bid) = CmmBranch (lookup bid)
txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f)
txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms)
txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r
txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
, succ = lookup (succ fc) }
txnode other = mapExpDeep exp other
exp :: CmmExpr -> CmmExpr
exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
exp e = e
mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
predMap :: [CmmBlock] -> BlockEnv BlockSet
predMap blocks = foldr add_preds mapEmpty blocks
where add_preds block env = foldl (add (entryLabel block)) env (successors block)
add bid env b' =
mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
removeUnreachableBlocks :: CmmGraph -> CmmGraph
removeUnreachableBlocks g
| length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
| otherwise = g
where blocks = postorderDfs g