-----------------------------------------------------------------------------
module CmmOpt (
+ cmmEliminateDeadBlocks,
cmmMiniInline,
cmmMachOpFold,
cmmLoopifyForC,
import Unique
import FastTypes
import Outputable
+import BlockId
import Data.Bits
import Data.Word
import Data.Int
+import Data.Maybe
+
+import Compiler.Hoopl hiding (Unique)
+
+-- -----------------------------------------------------------------------------
+-- Eliminates dead blocks
+
+{-
+We repeatedly expand the set of reachable blocks until we hit a
+fixpoint, and then prune any blocks that were not in this set. This is
+actually a required optimization, as dead blocks can cause problems
+for invariants in the linear register allocator (and possibly other
+places.)
+-}
+
+-- Deep fold over statements could probably be abstracted out, but it
+-- might not be worth the effort since OldCmm is moribund
+cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
+cmmEliminateDeadBlocks [] = []
+cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
+ let -- Calculate what's reachable from what block
+ -- We have to do a deep fold into CmmExpr because
+ -- there may be a BlockId in the CmmBlock literal.
+ reachableMap = foldl f emptyBlockMap blocks
+ where f m (BasicBlock block_id stmts) = mapInsert block_id (reachableFrom stmts) m
+ reachableFrom stmts = foldl stmt emptyBlockSet stmts
+ where
+ stmt m CmmNop = m
+ stmt m (CmmComment _) = m
+ stmt m (CmmAssign _ e) = expr m e
+ stmt m (CmmStore e1 e2) = expr (expr m e1) e2
+ stmt m (CmmCall c _ as _ _) = f (actuals m as) c
+ where f m (CmmCallee e _) = expr m e
+ f m (CmmPrim _) = m
+ stmt m (CmmBranch b) = setInsert b m
+ stmt m (CmmCondBranch e b) = setInsert b (expr m e)
+ stmt m (CmmSwitch e bs) = foldl (flip setInsert) (expr m e) (catMaybes bs)
+ stmt m (CmmJump e as) = expr (actuals m as) e
+ stmt m (CmmReturn as) = actuals m as
+ actuals m as = foldl (\m h -> expr m (hintlessCmm h)) m as
+ expr m (CmmLit l) = lit m l
+ expr m (CmmLoad e _) = expr m e
+ expr m (CmmReg _) = m
+ expr m (CmmMachOp _ es) = foldl expr m es
+ expr m (CmmStackSlot _ _) = m
+ expr m (CmmRegOff _ _) = m
+ lit m (CmmBlock b) = setInsert b m
+ lit m _ = m
+ -- Expand reachable set until you hit fixpoint
+ initReachable = setSingleton base_id :: BlockSet
+ expandReachable old_set new_set =
+ if setSize new_set > setSize old_set
+ then expandReachable new_set $ setFold
+ (\x s -> maybe setEmpty id (mapLookup x reachableMap) `setUnion` s)
+ new_set
+ (setDifference new_set old_set)
+ else new_set -- fixpoint achieved
+ reachable = expandReachable setEmpty initReachable
+ in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
-- -----------------------------------------------------------------------------
-- The mini-inliner