CmmContFlowOpt.hs 9.88 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 28
cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts split g = fst (blockConcat split g)
29

30 31 32
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
cmmCfgOptsProc split (CmmProc info lbl g) = CmmProc info' lbl g'
    where (g', env) = blockConcat split g
33 34
          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
          -- If we changed any labels, then we have to update the info tables
          -- too, except for the top-level info table because that might be
          -- referred to by other procs.
39 40
          upd_info (k,info)
             | Just k' <- mapLookup k env
41 42 43
             = (k', if k' == g_entry g'
                       then info
                       else info{ cit_lbl = infoTblLbl k' })
44 45 46
             | otherwise
             = (k,info)

47
cmmCfgOptsProc _ top = top
48

49

50 51
-----------------------------------------------------------------------------
--
52
-- Block concatenation
53 54 55
--
-----------------------------------------------------------------------------

56
-- This optimisation does three things:
57
--
58 59 60 61 62 63 64 65 66
--   - 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.
67
--     (but see Note [shortcut call returns])
68
--
69 70 71 72
--   - removes any unreachable blocks from the graph.  This is a side
--     effect of starting with a postorder DFS traversal of the graph
--

73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
-- 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
89
--
90 91 92 93 94 95 96 97
--    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.

98 99
blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId)
blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
100
  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
101
  where
102 103 104 105
     -- we might be able to shortcut the entry BlockId itself.
     -- remember to update the shortcut_map', since we also have to
     -- update the info_tbls mapping now.
     (new_entry, shortcut_map')
106 107
       | Just entry_blk <- mapLookup entry_id new_blocks
       , Just dest      <- canShortcut entry_blk
108
       = (dest, mapInsert entry_id dest shortcut_map)
109
       | otherwise
110
       = (entry_id, shortcut_map)
111

112
     blocks = postorderDfs g
113 114 115
     blockmap = foldr addBlock emptyBody blocks
      -- the initial blockmap is constructed from the postorderDfs result,
      -- so that we automatically throw away unreachable blocks.
116 117

     (new_blocks, shortcut_map) =
118
           foldr maybe_concat (blockmap, mapEmpty) blocks
119 120 121 122

     maybe_concat :: CmmBlock
                  -> (BlockEnv CmmBlock, BlockEnv BlockId)
                  -> (BlockEnv CmmBlock, BlockEnv BlockId)
123
     maybe_concat block (blocks, shortcut_map)
124 125
        | CmmBranch b' <- last
        , Just blk' <- mapLookup b' blocks
Simon Marlow's avatar
Simon Marlow committed
126 127
        , shouldConcatWith b' blk'
        = (mapInsert bid (splice head blk') blocks, shortcut_map)
128

129 130 131
        -- 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.
132 133
        | splitting_procs -- Note [shortcut call returns]
        , Just b'   <- callContinuation_maybe last
134
        , Just blk' <- mapLookup b' blocks
Simon Marlow's avatar
Simon Marlow committed
135 136
        , Just dest <- canShortcut blk'
        = (blocks, mapInsert b' dest shortcut_map)
137 138
           -- replaceLabels will substitute dest for b' everywhere, later

139 140 141 142 143 144 145
        -- 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)
146
        where
Simon Marlow's avatar
Simon Marlow committed
147 148
          (head, last) = blockSplitTail block
          bid = entryLabel block
149 150 151 152 153
          shortcut_last = mapSuccessors shortcut last
          shortcut l =
             case mapLookup l blocks of
               Just b | Just dest <- canShortcut b  -> dest
               _otherwise -> l
154 155 156

     shouldConcatWith b block
       | okToDuplicate block = True  -- short enough to duplicate
Simon Marlow's avatar
Simon Marlow committed
157
       | num_preds b == 1    = True  -- only one predecessor: go for it
158 159 160
       | otherwise           = False
       where num_preds bid = mapLookup bid backEdges `orElse` 0

Simon Marlow's avatar
Simon Marlow committed
161
     canShortcut :: CmmBlock -> Maybe BlockId
162
     canShortcut block
Simon Marlow's avatar
Simon Marlow committed
163
       | (_, middle, CmmBranch dest) <- blockSplit block
164 165 166 167 168 169
       , isEmptyBlock middle
       = Just dest
       | otherwise
       = Nothing

     backEdges :: BlockEnv Int -- number of predecessors for each block
Simon Marlow's avatar
Simon Marlow committed
170
     backEdges = mapInsertWith (+) entry_id 1 $ -- add 1 for the entry id
Simon Marlow's avatar
Simon Marlow committed
171
                   predMap blocks
172 173

     splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
Simon Marlow's avatar
Simon Marlow committed
174
     splice head rest = head `blockAppend` snd (blockSplitHead rest)
175 176 177 178 179 180 181


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
182
okToDuplicate :: CmmBlock -> Bool
183
okToDuplicate block
184 185 186 187 188 189 190
  = 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
191

192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220

{-  Note [shortcut call returns]

Consider this code that you might get from a recursive let-no-escape:

      goto L1
     L1:
      if (Hp > HpLim) then L2 else L3
     L2:
      call stg_gc_noregs returns to L4
     L4:
      goto L1
     L3:
      ...
      goto L1

Then the control-flow optimiser shortcuts L4.  But that turns L1
into the call-return proc point, and every iteration of the loop
has to shuffle variables to and from the stack.  So we must *not*
shortcut L4.

Moreover not shortcutting call returns is probably fine.  If L4 can
concat with its branch target then it will still do so.  And we
save some compile time because we don't have to traverse all the
code in replaceLabels.

However, we probably do want to do this if we are splitting proc
points, because L1 will be a proc-point anyway, so merging it with L4
reduces the number of proc points.  Unfortunately recursive
Simon Marlow's avatar
Simon Marlow committed
221 222 223
let-no-escapes won't generate very good code with proc-point splitting
on - we should probably compile them to explicitly use the native
calling convention instead.
224 225
-}

226 227 228
------------------------------------------------------------------------
-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied BlockEnv.
229 230

replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
231
replaceLabels env g
Simon Marlow's avatar
Simon Marlow committed
232 233
  | mapNull env = g
  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
234
   where
235
     replace_eid g = g {g_entry = lookup (g_entry g)}
236 237 238 239
     lookup id = mapLookup id env `orElse` id

     txnode :: CmmNode e x -> CmmNode e x
     txnode (CmmBranch bid)         = CmmBranch (lookup bid)
240
     txnode (CmmCondBranch p t f)   = mkCmmCondBranch (exp p) (lookup t) (lookup f)
241
     txnode (CmmSwitch e arms)      = CmmSwitch (exp e) (map (liftM lookup) arms)
242
     txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r
243 244 245 246 247
     txnode fc@CmmForeignCall{}     = fc{ args = map exp (args fc)
                                        , succ = lookup (succ fc) }
     txnode other                   = mapExpDeep exp other

     exp :: CmmExpr -> CmmExpr
248
     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
Simon Marlow's avatar
Simon Marlow committed
249
     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
250 251
     exp e                                      = e

Simon Marlow's avatar
Simon Marlow committed
252
mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
253
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
254 255 256

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

Simon Marlow's avatar
Simon Marlow committed
258
predMap :: [CmmBlock] -> BlockEnv Int
259
predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
Simon Marlow's avatar
Simon Marlow committed
260 261 262
  where
    add_preds block env = foldr add env (successors block)
      where add lbl env = mapInsertWith (+) lbl 1 env
263 264 265 266 267

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

268
removeUnreachableBlocks :: CmmGraph -> CmmGraph
269 270 271 272
removeUnreachableBlocks g
  | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
  | otherwise = g
  where blocks = postorderDfs g