compiler/cmm/CmmContFlowOpt.hs

   1
   2 module CmmContFlowOpt
   3     ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
   4     , branchChainElimZ, removeUnreachableBlocksZ, predMap
   5     , replaceLabelsZ, runCmmContFlowOptsZs
   6     )
   7 where
   8
   9 import BlockId
  10 import Cmm
  11 import CmmTx
  12 import qualified ZipCfg as G
  13 import ZipCfg
  14 import ZipCfgCmmRep
  15
  16 import Maybes
  17 import Monad
  18 import Outputable
  19 import Panic
  20 import Prelude hiding (unzip, zip)
  21 import Util
  22 import UniqFM
  23
  24 ------------------------------------
  25 runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ]
  26 runCmmContFlowOptsZs prog
  27   = [ runTx (runCmmOpts cmmCfgOptsZ) cmm_top
  28     | cmm_top <- prog ]
  29
  30 cmmCfgOpts  :: Tx (ListGraph CmmStmt)
  31 cmmCfgOptsZ :: Tx CmmGraph
  32
  33 cmmCfgOpts  = branchChainElim  -- boring, but will get more exciting later
  34 cmmCfgOptsZ = branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ
  35         -- Here branchChainElim can ultimately be replaced
  36         -- with a more exciting combination of optimisations
  37
  38 runCmmOpts :: Tx g -> Tx (GenCmm d h g)
  39 runCmmOpts opt = mapProcs (optGraph opt)
  40
  41 optGraph :: Tx g -> Tx (GenCmmTop d h g)
  42 optGraph _   top@(CmmData {}) = noTx top
  43 optGraph opt (CmmProc info lbl formals g) = fmap (CmmProc info lbl formals) (opt g)
  44
  45 ------------------------------------
  46 mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
  47 mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops)
  48
  49 ----------------------------------------------------------------
  50 branchChainElim :: Tx (ListGraph CmmStmt)
  51 -- If L is not captured in an instruction, we can remove any
  52 -- basic block of the form L: goto L', and replace L with L' everywhere else.
  53 -- How does L get captured? In a CallArea.
  54 branchChainElim (ListGraph blocks)
  55   | null lone_branch_blocks     -- No blocks to remove
  56   = noTx (ListGraph blocks)
  57   | otherwise
  58   = aTx (ListGraph new_blocks)
  59   where
  60     (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
  61     new_blocks = map (replaceLabels env) others
  62     env = mkClosureBlockEnv lone_branch_blocks
  63
  64 isLoneBranch :: CmmBasicBlock -> Either (BlockId, BlockId) CmmBasicBlock
  65 isLoneBranch (BasicBlock id [CmmBranch target]) | id /= target = Left (id, target)
  66 isLoneBranch other_block                                       = Right other_block
  67    -- An infinite loop is not a link in a branch chain!
  68
  69 replaceLabels :: BlockEnv BlockId -> CmmBasicBlock -> CmmBasicBlock
  70 replaceLabels env (BasicBlock id stmts)
  71   = BasicBlock id (map replace stmts)
  72   where
  73     replace (CmmBranch id)       = CmmBranch (lookup id)
  74     replace (CmmCondBranch e id) = CmmCondBranch e (lookup id)
  75     replace (CmmSwitch e tbl)    = CmmSwitch e (map (fmap lookup) tbl)
  76     replace other_stmt           = other_stmt
  77
  78     lookup id = lookupBlockEnv env id `orElse` id
  79 ----------------------------------------------------------------
  80 branchChainElimZ :: Tx CmmGraph
  81 -- Remove any basic block of the form L: goto L',
  82 -- and replace L with L' everywhere else
  83 branchChainElimZ g@(G.LGraph eid args _)
  84   | null lone_branch_blocks     -- No blocks to remove
  85   = noTx g
  86   | otherwise
  87   = aTx $ replaceLabelsZ env $ G.of_block_list eid args (self_branches ++ others)
  88   where
  89     (lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g)
  90     env = mkClosureBlockEnvZ lone_branch_blocks
  91     self_branches =
  92         let loop_to (id, _) =
  93                 if lookup id == id then
  94                     Just (G.Block id Nothing (G.ZLast (G.mkBranchNode id)))
  95                 else
  96                     Nothing
  97         in  mapMaybe loop_to lone_branch_blocks
  98     lookup id = lookupBlockEnv env id `orElse` id
  99
 100 isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
 101 isLoneBranchZ (G.Block id Nothing (G.ZLast (G.LastOther (LastBranch target))))
 102     | id /= target  = Left (id,target)
 103 isLoneBranchZ other = Right other
 104    -- An infinite loop is not a link in a branch chain!
 105
 106 replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 107 replaceLabelsZ env = replace_eid . G.map_nodes id middle last
 108   where
 109     replace_eid (G.LGraph eid off blocks) = G.LGraph (lookup eid) off blocks
 110     middle m@(MidComment _)            = m
 111     middle   (MidAssign r e)           = MidAssign r (exp e)
 112     middle   (MidStore addr e)         = MidStore (exp addr) (exp e)
 113     middle   (MidUnsafeCall tgt fs as) = MidUnsafeCall (midcall tgt) fs (map exp as)
 114     middle   (MidAddToContext e es)    = MidAddToContext (exp e) (map exp es)
 115     last (LastBranch id)             = LastBranch (lookup id)
 116     last (LastCondBranch e ti fi)    = LastCondBranch (exp e) (lookup ti) (lookup fi)
 117     last (LastSwitch e tbl)          = LastSwitch (exp e) (map (fmap lookup) tbl)
 118     last (LastCall tgt mb_id s)      = LastCall (exp tgt) (fmap lookup mb_id) s
 119     last (LastJump e s)              = LastJump (exp e) s
 120     last (LastReturn s)              = LastReturn s
 121     midcall   (ForeignTarget e c)    = ForeignTarget (exp e) c
 122     midcall m@(PrimTarget _)         = m
 123     exp e@(CmmLit _)         = e
 124     exp   (CmmLoad addr ty)  = CmmLoad (exp addr) ty
 125     exp e@(CmmReg _)         = e
 126     exp   (CmmMachOp op es)  = CmmMachOp op $ map exp es
 127     exp e@(CmmRegOff _ _)    = e
 128     exp   (CmmStackSlot (CallArea (Young id)) i) =
 129       CmmStackSlot (CallArea (Young (lookup id))) i
 130     exp e@(CmmStackSlot _ _) = e
 131     lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id
 132
 133 ----------------------------------------------------------------
 134 -- Build a map from a block to its set of predecessors. Very useful.
 135 predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet
 136 predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
 137   where add_preds b env = foldl (add b) env (G.succs b)
 138         add (G.Block bid _ _) env b' =
 139           extendBlockEnv env b' $
 140                 extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid
 141 ----------------------------------------------------------------
 142 -- If a block B branches to a label L, and L has no other predecessors,
 143 -- then we can splice the block starting with L onto the end of B.
 144 -- Because this optmization can be inhibited by unreachable blocks,
 145 -- we first take a pass to drops unreachable blocks.
 146 -- Order matters, so we work bottom up (reverse postorder DFS).
 147 --
 148 -- To ensure correctness, we have to make sure that the BlockId of the block
 149 -- we are about to eliminate is not named in another instruction
 150 -- (except an adjacent stack pointer adjustment, which we expect and also eliminate).
 151 -- For
 152 --
 153 -- Note: This optimization does _not_ subsume branch chain elimination.
 154 blockConcatZ  :: Tx CmmGraph
 155 blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
 156 blockConcatZ' :: Tx CmmGraph
 157 blockConcatZ' g@(G.LGraph eid off blocks) =
 158   tx $ pprTrace "concatMap" (ppr concatMap) $ replaceLabelsZ concatMap $ G.LGraph eid off blocks'
 159   where (changed, blocks', concatMap) =
 160            foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g
 161         maybe_concat b@(G.Block bid _ _) (changed, blocks', concatMap) =
 162           let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap)
 163           in case G.goto_end $ G.unzip b of
 164                (h, G.LastOther (LastBranch b')) ->
 165                   if num_preds b' == 1 then
 166                     (True, extendBlockEnv blocks' bid $ splice blocks' h b',
 167                      extendBlockEnv concatMap b' bid)
 168                   else unchanged
 169                _ -> unchanged
 170         num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
 171         backEdges = predMap g
 172         splice blocks' h bid' =
 173           case lookupBlockEnv blocks' bid' of
 174             Just (G.Block _ Nothing t) -> G.zip $ G.ZBlock h t
 175             Just (G.Block _ (Just _) _) ->
 176               panic "trying to concatenate but successor block has incoming args"
 177             Nothing -> panic "unknown successor block"
 178         tx = if changed then aTx else noTx
 179 ----------------------------------------------------------------
 180 mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
 181 mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
 182     where singleEnv = mkBlockEnv blocks
 183           follow (id, next) = (id, endChain id next)
 184           endChain orig id = case lookupBlockEnv singleEnv id of
 185                                Just id' | id /= orig -> endChain orig id'
 186                                _ -> id
 187 mkClosureBlockEnvZ :: [(BlockId, BlockId)] -> BlockEnv BlockId
 188 mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks
 189     where singleEnv = mkBlockEnv blocks
 190           follow (id, next) = (id, endChain id next)
 191           endChain orig id = case lookupBlockEnv singleEnv id of
 192                                Just id' | id /= orig -> endChain orig id'
 193                                _ -> id
 194 ----------------------------------------------------------------
 195 removeUnreachableBlocksZ :: Tx CmmGraph
 196 removeUnreachableBlocksZ g@(G.LGraph id off blocks) =
 197       if length blocks' < sizeUFM blocks then aTx $ G.of_block_list id off blocks'
 198       else noTx g
 199     where blocks' = G.postorder_dfs g