[commit: ghc] master: Implement dead basic block elimination. (50f5c84)

[Simon Marlow]

On 30/04/2011 15:18, Edward Z. Yang wrote:
> 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<ezyang at mit.edu>
> Date:   Tue Apr 5 17:38:15 2011 +0100
>
>      Implement dead basic block elimination.
>
>      Signed-off-by: Edward Z. Yang<ezyang at mit.edu>
>
>> ---------------------------------------------------------------
>
>   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

I think a better way to do a closure operation like this is with two 
sets: a set of objects "Done" that you have already processed, and a set 
of objects "ToDo" still to be processed.  For each block B in ToDo: add 
the block to Done, and add any new references from B to ToDo (if they 
aren't already in Done).  When ToDo is empty, you're done.  ToDo can be 
a list even, it doesn't need to be a set.

This way you don't look at references from the same block multiple 
times, you don't need to precalculate reachableMap, and you don't 
repeatedly compute the size of sets.

Cheers,
	Simon