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

4
module CmmContFlowOpt
5
    ( cmmCfgOpts
Simon Marlow's avatar
Simon Marlow committed
6
    , cmmCfgOptsProc
7 8
    , removeUnreachableBlocks
    , replaceLabels
9 10 11
    )
where

12
import BlockId
13
import Cmm
14
import CmmUtils
15
import Maybes
16

Simon Marlow's avatar
Simon Marlow committed
17
import 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
cmmCfgOpts :: CmmGraph -> CmmGraph
28
cmmCfgOpts g = fst (blockConcat g)
29

Simon Marlow's avatar
Simon Marlow committed
30
cmmCfgOptsProc :: CmmDecl -> CmmDecl
31
cmmCfgOptsProc (CmmProc info lbl g) = CmmProc info' lbl g'
32 33 34
    where (g', env) = blockConcat g
          info' = info{ info_tbls = new_info_tbls }
          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
Simon Marlow's avatar
Simon Marlow committed
35

36 37 38 39 40 41 42
          upd_info (k,info)
             | Just k' <- mapLookup k env
             = (k', info{ cit_lbl = infoTblLbl k' })
             | otherwise
             = (k,info)

cmmCfgOptsProc top = top
43

44

45 46
-----------------------------------------------------------------------------
--
47
-- Block concatenation
48 49 50
--
-----------------------------------------------------------------------------

51
-- This optimisation does three things:
52 53 54 55 56 57 58 59 60 61
--   - If a block finishes with an unconditional branch, then we may
--     be able to concatenate the block it points to and remove the
--     branch.  We do this either if the destination block is small
--     (e.g. just another branch), or if this is the only jump to
--     this particular destination block.
--
--   - If a block finishes in a call whose continuation block is a
--     goto, then we can shortcut the destination, making the
--     continuation block the destination of the goto.
--
62 63 64 65
--   - removes any unreachable blocks from the graph.  This is a side
--     effect of starting with a postorder DFS traversal of the graph
--

66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
-- Both transformations are improved by working from the end of the
-- graph towards the beginning, because we may be able to perform many
-- shortcuts in one go.


-- We need to walk over the blocks from the end back to the
-- beginning.  We are going to maintain the "current" graph
-- (BlockEnv CmmBlock) as we go, and also a mapping from BlockId
-- to BlockId, representing continuation labels that we have
-- renamed.  This latter mapping is important because we might
-- shortcut a CmmCall continuation.  For example:
--
--    Sp[0] = L
--    call g returns to L
--
--    L: goto M
82
--
83 84 85 86 87 88 89 90
--    M: ...
--
-- So when we shortcut the L block, we need to replace not only
-- the continuation of the call, but also references to L in the
-- code (e.g. the assignment Sp[0] = L).  So we keep track of
-- which labels we have renamed and apply the mapping at the end
-- with replaceLabels.

91
blockConcat  :: CmmGraph -> (CmmGraph, BlockEnv BlockId)
92
blockConcat g@CmmGraph { g_entry = entry_id }
93
  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map)
94
  where
95 96 97 98 99 100 101
     -- we might be able to shortcut the entry BlockId itself
     new_entry
       | Just entry_blk <- mapLookup entry_id new_blocks
       , Just dest      <- canShortcut entry_blk
       = dest
       | otherwise
       = entry_id
102

103
     blocks = postorderDfs g
104 105 106
     blockmap = foldr addBlock emptyBody blocks
      -- the initial blockmap is constructed from the postorderDfs result,
      -- so that we automatically throw away unreachable blocks.
107 108

     (new_blocks, shortcut_map) =
109
           foldr maybe_concat (blockmap, mapEmpty) blocks
110 111 112 113

     maybe_concat :: CmmBlock
                  -> (BlockEnv CmmBlock, BlockEnv BlockId)
                  -> (BlockEnv CmmBlock, BlockEnv BlockId)
114
     maybe_concat block (blocks, shortcut_map)
115 116
        | CmmBranch b' <- last
        , Just blk' <- mapLookup b' blocks
Simon Marlow's avatar
Simon Marlow committed
117 118
        , shouldConcatWith b' blk'
        = (mapInsert bid (splice head blk') blocks, shortcut_map)
119

120 121 122
        -- calls: if we can shortcut the continuation label, then
        -- we must *also* remember to substitute for the label in the
        -- code, because we will push it somewhere.
123 124
        | Just b'   <- callContinuation_maybe last
        , Just blk' <- mapLookup b' blocks
Simon Marlow's avatar
Simon Marlow committed
125 126
        , Just dest <- canShortcut blk'
        = (blocks, mapInsert b' dest shortcut_map)
127 128
           -- replaceLabels will substitute dest for b' everywhere, later

129 130 131 132 133 134 135
        -- non-calls: see if we can shortcut any of the successors.
        | Nothing <- callContinuation_maybe last
        = ( mapInsert bid (blockJoinTail head shortcut_last) blocks
          , shortcut_map )

        | otherwise
        = (blocks, shortcut_map)
136
        where
Simon Marlow's avatar
Simon Marlow committed
137 138
          (head, last) = blockSplitTail block
          bid = entryLabel block
139 140 141 142 143
          shortcut_last = mapSuccessors shortcut last
          shortcut l =
             case mapLookup l blocks of
               Just b | Just dest <- canShortcut b  -> dest
               _otherwise -> l
144 145 146 147 148 149 150

     shouldConcatWith b block
       | num_preds b == 1    = True  -- only one predecessor: go for it
       | okToDuplicate block = True  -- short enough to duplicate
       | otherwise           = False
       where num_preds bid = mapLookup bid backEdges `orElse` 0

Simon Marlow's avatar
Simon Marlow committed
151
     canShortcut :: CmmBlock -> Maybe BlockId
152
     canShortcut block
Simon Marlow's avatar
Simon Marlow committed
153
       | (_, middle, CmmBranch dest) <- blockSplit block
154 155 156 157 158 159
       , isEmptyBlock middle
       = Just dest
       | otherwise
       = Nothing

     backEdges :: BlockEnv Int -- number of predecessors for each block
Simon Marlow's avatar
Simon Marlow committed
160 161
     backEdges = mapInsertWith (+) entry_id 1 $ -- add 1 for the entry id
                   mapMap setSize $ predMap blocks
162 163

     splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
Simon Marlow's avatar
Simon Marlow committed
164
     splice head rest = head `blockAppend` snd (blockSplitHead rest)
165 166 167 168 169 170 171


callContinuation_maybe :: CmmNode O C -> Maybe BlockId
callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
callContinuation_maybe (CmmForeignCall { succ = b })   = Just b
callContinuation_maybe _ = Nothing

Simon Marlow's avatar
Simon Marlow committed
172
okToDuplicate :: CmmBlock -> Bool
173
okToDuplicate block
174 175 176 177 178 179 180
  = case blockSplit block of
      (_, m, CmmBranch _) -> isEmptyBlock m
      -- cheap and cheerful; we might expand this in the future to
      -- e.g. spot blocks that represent a single instruction or two.
      -- Be careful: a CmmCall can be more than one instruction, it
      -- has a CmmExpr inside it.
      _otherwise -> False
181 182 183 184

------------------------------------------------------------------------
-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied BlockEnv.
185 186

replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
187
replaceLabels env g
Simon Marlow's avatar
Simon Marlow committed
188 189
  | mapNull env = g
  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
190
   where
191
     replace_eid g = g {g_entry = lookup (g_entry g)}
192 193 194 195
     lookup id = mapLookup id env `orElse` id

     txnode :: CmmNode e x -> CmmNode e x
     txnode (CmmBranch bid)         = CmmBranch (lookup bid)
196
     txnode (CmmCondBranch p t f)   = mkCmmCondBranch (exp p) (lookup t) (lookup f)
197
     txnode (CmmSwitch e arms)      = CmmSwitch (exp e) (map (liftM lookup) arms)
198
     txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r
199 200 201 202 203
     txnode fc@CmmForeignCall{}     = fc{ args = map exp (args fc)
                                        , succ = lookup (succ fc) }
     txnode other                   = mapExpDeep exp other

     exp :: CmmExpr -> CmmExpr
204
     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
Simon Marlow's avatar
Simon Marlow committed
205
     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
206 207
     exp e                                      = e

Simon Marlow's avatar
Simon Marlow committed
208
mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
209
mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
210 211 212

----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful.
213

214 215 216 217 218
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
219 220 221 222 223 224


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

225
removeUnreachableBlocks :: CmmGraph -> CmmGraph
226 227 228 229
removeUnreachableBlocks g
  | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
  | otherwise = g
  where blocks = postorderDfs g