Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/50f5c8491bfcb6b891f772e2915443dbb5078e97 >--------------------------------------------------------------- commit 50f5c8491bfcb6b891f772e2915443dbb5078e97 Author: Edward Z. Yang <[email protected]> Date: Tue Apr 5 17:38:15 2011 +0100 Implement dead basic block elimination. Signed-off-by: Edward Z. Yang <[email protected]> >--------------------------------------------------------------- compiler/cmm/CmmOpt.hs | 61 +++++++++++++++++++++++++++++++++++++ compiler/nativeGen/AsmCodeGen.lhs | 7 ++-- 2 files changed, 64 insertions(+), 4 deletions(-) diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index c71f188..1c7e7e5 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- module CmmOpt ( + cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold, cmmLoopifyForC, @@ -30,10 +31,70 @@ import UniqFM 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 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index eeb5f2e..06e6d6d 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -58,7 +58,7 @@ import NCGMonad import BlockId import CgUtils ( fixStgRegisters ) import OldCmm -import CmmOpt ( cmmMiniInline, cmmMachOpFold ) +import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) import OldPprCmm import CLabel @@ -729,10 +729,9 @@ Here we do: and position independent refs (ii) compile a list of imported symbols -Ideas for other things we could do (ToDo): +Ideas for other things we could do: - shortcut jumps-to-jumps - - eliminate dead code blocks - simple CSE: if an expr is assigned to a temp, then replace later occs of that expr with the temp, until the expr is no longer valid (can push through temp assignments, and certain assigns to mem...) @@ -741,7 +740,7 @@ Ideas for other things we could do (ToDo): cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do - blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) + blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks)) return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
