compiler/cmm/CmmContFlowOpt.hs

   1 {-# LANGUAGE GADTs #-}
   2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
   3
   4 module CmmContFlowOpt
   5     ( runCmmOpts, oldCmmCfgOpts, cmmCfgOpts
   6     , branchChainElim, removeUnreachableBlocks, predMap
   7     , replaceLabels, replaceBranches, runCmmContFlowOpts
   8     )
   9 where
  10
  11 import BlockId
  12 import Cmm
  13 import CmmDecl
  14 import CmmExpr
  15 import qualified OldCmm as Old
  16
  17 import Maybes
  18 import Compiler.Hoopl
  19 import Control.Monad
  20 import Outputable
  21 import Prelude hiding (succ, unzip, zip)
  22 import Util
  23
  24 ------------------------------------
  25 runCmmContFlowOpts :: Cmm -> Cmm
  26 runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog
  27
  28 oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
  29 cmmCfgOpts    :: CmmGraph -> CmmGraph
  30
  31 oldCmmCfgOpts = oldBranchChainElim  -- boring, but will get more exciting later
  32 cmmCfgOpts    =
  33   removeUnreachableBlocks . blockConcat . branchChainElim
  34         -- Here branchChainElim can ultimately be replaced
  35         -- with a more exciting combination of optimisations
  36
  37 runCmmOpts :: (g -> g) -> GenCmm d h g -> GenCmm d h g
  38 -- Lifts a transformer on a single graph to one on the whole program
  39 runCmmOpts opt = mapProcs (optProc opt)
  40
  41 optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g
  42 optProc _   top@(CmmData {}) = top
  43 optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
  44
  45 ------------------------------------
  46 mapProcs :: (GenCmmTop d h s -> GenCmmTop d h s) -> GenCmm d h s -> GenCmm d h s
  47 mapProcs f (Cmm tops) = Cmm (map f tops)
  48
  49 ----------------------------------------------------------------
  50 oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.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 oldBranchChainElim (Old.ListGraph blocks)
  55   | null lone_branch_blocks     -- No blocks to remove
  56   = Old.ListGraph blocks
  57   | otherwise
  58   = Old.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 :: Old.CmmBasicBlock -> Either (BlockId, BlockId) Old.CmmBasicBlock
  65     isLoneBranch (Old.BasicBlock id [Old.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 -> Old.CmmBasicBlock -> Old.CmmBasicBlock
  70     replaceLabels env (Old.BasicBlock id stmts)
  71       = Old.BasicBlock id (map replace stmts)
  72       where
  73         replace (Old.CmmBranch id)       = Old.CmmBranch (lookup id)
  74         replace (Old.CmmCondBranch e id) = Old.CmmCondBranch e (lookup id)
  75         replace (Old.CmmSwitch e tbl)    = Old.CmmSwitch e (map (fmap lookup) tbl)
  76         replace other_stmt           = other_stmt
  77
  78         lookup id = mapLookup id env `orElse` id
  79
  80 ----------------------------------------------------------------
  81 branchChainElim :: CmmGraph -> CmmGraph
  82 -- Remove any basic block of the form L: goto L',
  83 -- and replace L with L' everywhere else,
  84 -- unless L is the successor of a call instruction and L'
  85 -- is the entry block. You don't want to set the successor
  86 -- of a function call to the entry block because there is no good way
  87 -- to store both the infotables for the call and from the callee,
  88 -- while putting the stack pointer in a consistent place.
  89 --
  90 -- JD isn't quite sure when it's safe to share continuations for different
  91 -- function calls -- have to think about where the SP will be,
  92 -- so we'll table that problem for now by leaving all call successors alone.
  93 branchChainElim g
  94   | null lone_branch_blocks     -- No blocks to remove
  95   = g
  96   | otherwise
  97   = replaceLabels env $ ofBlockList (g_entry g) (self_branches ++ others)
  98   where
  99     blocks = toBlockList g
 100     (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
 101     env = mkClosureBlockEnv lone_branch_blocks
 102     self_branches =
 103       let loop_to (id, _) =
 104             if lookup id == id then
 105               Just $ blockOfNodeList (JustC (CmmEntry id), [], JustC (mkBranchNode id))
 106             else
 107               Nothing
 108       in  mapMaybe loop_to lone_branch_blocks
 109     lookup id = mapLookup id env `orElse` id
 110
 111     call_succs = foldl add emptyBlockSet blocks
 112       where add :: BlockSet -> CmmBlock -> BlockSet
 113             add succs b =
 114               case lastNode b of
 115                 (CmmCall _ (Just k) _ _ _) -> setInsert k succs
 116                 (CmmForeignCall {succ=k})  -> setInsert k succs
 117                 _                          -> succs
 118     isLoneBranch :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
 119     isLoneBranch block | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block,
 120                          id /= target && not (setMember id call_succs)
 121                        = Left (id,target)
 122     isLoneBranch other = Right other
 123        -- An infinite loop is not a link in a branch chain!
 124
 125 maybeReplaceLabels :: (CmmNode O C -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
 126 maybeReplaceLabels lpred env =
 127   replace_eid . mapGraphNodes (id, middle, last)
 128    where
 129      replace_eid g = g {g_entry = lookup (g_entry g)}
 130      lookup id = fmap lookup (mapLookup id env) `orElse` id
 131
 132      middle = mapExpDeep exp
 133      last l = if lpred l then mapExpDeep exp (last' l) else l
 134      last' :: CmmNode O C -> CmmNode O C
 135      last' (CmmBranch bid)             = CmmBranch (lookup bid)
 136      last' (CmmCondBranch p t f)       = CmmCondBranch p (lookup t) (lookup f)
 137      last' (CmmSwitch e arms)          = CmmSwitch e (map (liftM lookup) arms)
 138      last' (CmmCall t k a res r)       = CmmCall t (liftM lookup k) a res r
 139      last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (lookup bid) u i
 140
 141      exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
 142      exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
 143      exp e                                      = e
 144
 145
 146 replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 147 replaceLabels = maybeReplaceLabels (const True)
 148
 149 replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 150 replaceBranches env g = mapGraphNodes (id, id, last) g
 151   where
 152     last :: CmmNode O C -> CmmNode O C
 153     last (CmmBranch id)          = CmmBranch (lookup id)
 154     last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
 155     last (CmmSwitch e tbl)       = CmmSwitch e (map (fmap lookup) tbl)
 156     last l@(CmmCall {})          = l
 157     last l@(CmmForeignCall {})   = l
 158     lookup id = fmap lookup (mapLookup id env) `orElse` id
 159
 160 ----------------------------------------------------------------
 161 -- Build a map from a block to its set of predecessors. Very useful.
 162 predMap :: [CmmBlock] -> BlockEnv BlockSet
 163 predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
 164   where add_preds block env = foldl (add (entryLabel block)) env (successors block)
 165         add bid env b' =
 166           mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
 167 ----------------------------------------------------------------
 168 -- If a block B branches to a label L, L is not the entry block,
 169 -- and L has no other predecessors,
 170 -- then we can splice the block starting with L onto the end of B.
 171 -- Order matters, so we work bottom up (reverse postorder DFS).
 172 -- This optimization can be inhibited by unreachable blocks, but
 173 -- the reverse postorder DFS returns only reachable blocks.
 174 --
 175 -- To ensure correctness, we have to make sure that the BlockId of the block
 176 -- we are about to eliminate is not named in another instruction.
 177 --
 178 -- Note: This optimization does _not_ subsume branch chain elimination.
 179 blockConcat  :: CmmGraph -> CmmGraph
 180 blockConcat g@(CmmGraph {g_entry=eid}) =
 181   replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
 182   where blocks = postorderDfs g
 183         (blocks', concatMap) =
 184            foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
 185         maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
 186         maybe_concat b unchanged@(blocks', concatMap) =
 187           let bid = entryLabel b
 188           in case blockToNodeList b of
 189                (JustC h, m, JustC (CmmBranch b')) ->
 190                   if canConcatWith b' then
 191                     (mapInsert bid (splice blocks' h m b') blocks',
 192                      mapInsert b' bid concatMap)
 193                   else unchanged
 194                _ -> unchanged
 195         num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0
 196         canConcatWith b' = b' /= eid && num_preds b' == 1
 197         backEdges = predMap blocks
 198         splice :: forall map n e x.
 199                   IsMap map =>
 200                   map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
 201         splice blocks' h m bid' =
 202           case mapLookup bid' blocks' of
 203             Nothing -> panic "unknown successor block"
 204             Just block | (_, m', l') <- blockToNodeList block -> blockOfNodeList (JustC h, (m ++ m'), l')
 205 ----------------------------------------------------------------
 206 mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
 207 mkClosureBlockEnv blocks = mapFromList $ map follow blocks
 208     where singleEnv = mapFromList blocks :: BlockEnv BlockId
 209           follow (id, next) = (id, endChain id next)
 210           endChain orig id = case mapLookup id singleEnv of
 211                                Just id' | id /= orig -> endChain orig id'
 212                                _ -> id
 213 ----------------------------------------------------------------
 214 removeUnreachableBlocks :: CmmGraph -> CmmGraph
 215 removeUnreachableBlocks g =
 216   if length blocks < mapSize (toBlockMap g) then ofBlockList (g_entry g) blocks
 217                                            else g
 218     where blocks = postorderDfs g