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

[Edward Z. Yang]

Fixed up in 246183c669a1e851ccc4

Edward

Excerpts from Simon Marlow's message of Thu May 05 08:57:10 -0400 2011:
> 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