CmmContFlowOpt.hs 8.6 KB
Newer Older
1 2
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
3

4
module CmmContFlowOpt
5 6
    ( runCmmContFlowOpts
    , removeUnreachableBlocks, replaceBranches
7 8 9
    )
where

10
import BlockId
11
import Cmm
12
import CmmUtils
13
import Digraph
14
import Maybes
15 16
import Outputable

17
import Compiler.Hoopl
Ian Lynagh's avatar
Ian Lynagh committed
18
import Control.Monad
19
import Prelude hiding (succ, unzip, zip)
20

21 22 23 24 25
-----------------------------------------------------------------------------
--
-- Control-flow optimisations
--
-----------------------------------------------------------------------------
26

27 28
runCmmContFlowOpts :: CmmGroup -> CmmGroup
runCmmContFlowOpts = map (optProc cmmCfgOpts)
29

30 31
cmmCfgOpts :: CmmGraph -> CmmGraph
cmmCfgOpts = removeUnreachableBlocks . blockConcat . branchChainElim
32 33 34
        -- Here branchChainElim can ultimately be replaced
        -- with a more exciting combination of optimisations

Simon Peyton Jones's avatar
Simon Peyton Jones committed
35
optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
36
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
37
optProc _   top                  = top
38

39 40 41 42 43 44 45 46 47 48 49 50
-----------------------------------------------------------------------------
--
-- Branch Chain Elimination
--
-----------------------------------------------------------------------------

-- | Remove any basic block of the form L: goto L', and replace L with
-- L' everywhere else, unless L is the successor of a call instruction
-- and L' is the entry block. You don't want to set the successor of a
-- function call to the entry block because there is no good way to
-- store both the infotables for the call and from the callee, while
-- putting the stack pointer in a consistent place.
51 52 53 54
--
-- JD isn't quite sure when it's safe to share continuations for different
-- function calls -- have to think about where the SP will be,
-- so we'll table that problem for now by leaving all call successors alone.
55 56

branchChainElim :: CmmGraph -> CmmGraph
57
branchChainElim g
58
  | null lone_branch_blocks = g    -- No blocks to remove
Simon Marlow's avatar
Simon Marlow committed
59 60
  | otherwise               = {- pprTrace "branchChainElim" (ppr forest) $ -}
                              replaceLabels (mapFromList edges) g
61
  where
62
    blocks = toBlockList g
63 64 65 66 67

    lone_branch_blocks :: [(BlockId, BlockId)]
      -- each (L,K) is a block of the form
      --   L : goto K
    lone_branch_blocks = mapCatMaybes isLoneBranch blocks
68

69
    call_succs = foldl add emptyBlockSet blocks
70 71 72 73 74 75
      where add :: BlockSet -> CmmBlock -> BlockSet
            add succs b =
              case lastNode b of
                (CmmCall _ (Just k) _ _ _) -> setInsert k succs
                (CmmForeignCall {succ=k})  -> setInsert k succs
                _                          -> succs
76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117

    isLoneBranch :: CmmBlock -> Maybe (BlockId, BlockId)
    isLoneBranch block
      | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block
      , not (setMember id call_succs)
      = Just (id,target)
      | otherwise
      = Nothing

    -- We build a graph from lone_branch_blocks (every node has only
    -- one out edge).  Then we
    --   - topologically sort the graph: if from A we can reach B,
    --     then A occurs before B in the result list.
    --   - depth-first search starting from the nodes in this list.
    --     This gives us a [[node]], in which each list is a dependency
    --     chain.
    --   - for each list [a1,a2,...an] replace branches to ai with an.
    --
    -- This approach nicely deals with cycles by ignoring them.
    -- Branches in a cycle will be redirected to somewhere in the
    -- cycle, but we don't really care where.  A cycle should be dead code,
    -- and so will be eliminated by removeUnreachableBlocks.
    --
    fromNode (b,_) = b
    toNode   a     = (a,a)

    all_block_ids :: LabelSet
    all_block_ids = setFromList (map fst lone_branch_blocks)
                      `setUnion`
                    setFromList (map snd lone_branch_blocks)

    forest = dfsTopSortG $ graphFromVerticesAndAdjacency nodes lone_branch_blocks
        where nodes = map toNode $ setElems $ all_block_ids

    edges  = [ (fromNode y, fromNode x)
             | (x:xs) <- map reverse forest, y <- xs ]

----------------------------------------------------------------

replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceLabels env =
  replace_eid . mapGraphNodes1 txnode
118
   where
119
     replace_eid g = g {g_entry = lookup (g_entry g)}
120 121 122 123 124 125 126 127 128 129 130 131
     lookup id = mapLookup id env `orElse` id

     txnode :: CmmNode e x -> CmmNode e x
     txnode (CmmBranch bid)         = CmmBranch (lookup bid)
     txnode (CmmCondBranch p t f)   = CmmCondBranch (exp p) (lookup t) (lookup f)
     txnode (CmmSwitch e arms)      = CmmSwitch (exp e) (map (liftM lookup) arms)
     txnode (CmmCall t k a res r)   = CmmCall (exp t) (liftM lookup k) a res r
     txnode fc@CmmForeignCall{}     = fc{ args = map exp (args fc)
                                        , succ = lookup (succ fc) }
     txnode other                   = mapExpDeep exp other

     exp :: CmmExpr -> CmmExpr
132 133 134 135 136
     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
     exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
     exp e                                      = e


137
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
138
replaceBranches env g = mapGraphNodes (id, id, last) g
139
  where
140 141 142 143 144 145 146
    last :: CmmNode O C -> CmmNode O C
    last (CmmBranch id)          = CmmBranch (lookup id)
    last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
    last (CmmSwitch e tbl)       = CmmSwitch e (map (fmap lookup) tbl)
    last l@(CmmCall {})          = l
    last l@(CmmForeignCall {})   = l
    lookup id = fmap lookup (mapLookup id env) `orElse` id
147 148
            -- XXX: this is a recursive lookup, it follows chains until the lookup
            -- returns Nothing, at which point we return the last BlockId
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
149 150 151

----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful.
152 153 154 155 156
predMap :: [CmmBlock] -> BlockEnv BlockSet
predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
  where add_preds block env = foldl (add (entryLabel block)) env (successors block)
        add bid env b' =
          mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
157 158 159 160 161 162 163

-----------------------------------------------------------------------------
--
-- Block concatenation
--
-----------------------------------------------------------------------------

164 165
-- If a block B branches to a label L, L is not the entry block,
-- and L has no other predecessors,
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
166 167
-- then we can splice the block starting with L onto the end of B.
-- Order matters, so we work bottom up (reverse postorder DFS).
168 169
-- This optimization can be inhibited by unreachable blocks, but
-- the reverse postorder DFS returns only reachable blocks.
170 171
--
-- To ensure correctness, we have to make sure that the BlockId of the block
172
-- we are about to eliminate is not named in another instruction.
173
--
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
174
-- Note: This optimization does _not_ subsume branch chain elimination.
175

176 177 178
blockConcat  :: CmmGraph -> CmmGraph
blockConcat g@(CmmGraph {g_entry=eid}) =
  replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
179 180 181 182
  where
     blocks = postorderDfs g

     (blocks', concatMap) =
183
           foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205

     maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
     maybe_concat b unchanged@(blocks', concatMap) =
       let bid = entryLabel b
       in case blockToNodeList b of
            (JustC h, m, JustC (CmmBranch b')) ->
               if canConcatWith b' then
                 (mapInsert bid (splice blocks' h m b') blocks',
                  mapInsert b' bid concatMap)
               else unchanged
            _ -> unchanged

     num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0

     canConcatWith b' = b' /= eid && num_preds b' == 1

     backEdges = predMap blocks

     splice :: forall map n e x.
               IsMap map =>
               map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
     splice blocks' h m bid' =
206
          case mapLookup bid' blocks' of
207
            Nothing -> panic "unknown successor block"
208 209 210 211 212 213 214 215 216 217
            Just block | (_, m', l') <- blockToNodeList block
                -> blockOfNodeList (JustC h, (m ++ m'), l')


-----------------------------------------------------------------------------
--
-- Removing unreachable blocks
--
-----------------------------------------------------------------------------

218
removeUnreachableBlocks :: CmmGraph -> CmmGraph
219 220 221 222
removeUnreachableBlocks g
  | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
  | otherwise = g
  where blocks = postorderDfs g