CmmContFlowOpt.hs 10.8 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
    , removeUnreachableBlocksProc
8 9
    , removeUnreachableBlocks
    , replaceLabels
10 11 12
    )
where

13
import Hoopl
14
import BlockId
15
import Cmm
16
import CmmUtils
17
import Maybes
18

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

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

28 29
cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
cmmCfgOpts split g = fst (blockConcat split g)
30

31
cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
32
cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
33
    where (g', env) = blockConcat split g
34 35
          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
36

37 38 39
          -- 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.
40 41
          upd_info (k,info)
             | Just k' <- mapLookup k env
42 43 44
             = (k', if k' == g_entry g'
                       then info
                       else info{ cit_lbl = infoTblLbl k' })
45 46 47
             | otherwise
             = (k,info)

48
cmmCfgOptsProc _ top = top
49

50

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

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

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

99 100
blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId)
blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
101
  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
102
  where
103 104 105 106
     -- 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')
107 108
       | Just entry_blk <- mapLookup entry_id new_blocks
       , Just dest      <- canShortcut entry_blk
109
       = (dest, mapInsert entry_id dest shortcut_map)
110
       | otherwise
111
       = (entry_id, shortcut_map)
112

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

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

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

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

140 141
        -- non-calls: see if we can shortcut any of the successors,
        -- and check whether we should invert the conditional
142
        | Nothing <- callContinuation_maybe last
143
        = ( mapInsert bid (blockJoinTail head swapcond_last) blocks
144 145 146 147
          , shortcut_map )

        | otherwise
        = (blocks, shortcut_map)
148
        where
Simon Marlow's avatar
Simon Marlow committed
149 150
          (head, last) = blockSplitTail block
          bid = entryLabel block
151

152
          shortcut_last = mapSuccessors shortcut last
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
            where
              shortcut l =
                 case mapLookup l blocks of
                   Just b | Just dest <- canShortcut b  -> dest
                   _otherwise -> l

          -- for a conditional, we invert the conditional if that
          -- would make it more likely that the branch-not-taken case
          -- becomes a fallthrough.  This helps the native codegen a
          -- little bit, and probably has no effect on LLVM.  It's
          -- convenient to do it here, where we have the information
          -- about predecessors.
          --
          swapcond_last
            | CmmCondBranch cond t f <- shortcut_last
            , numPreds f > 1
            , numPreds t == 1
            , Just cond' <- maybeInvertCmmExpr cond
            = CmmCondBranch cond' f t

            | otherwise
            = shortcut_last

176 177 178

     shouldConcatWith b block
       | okToDuplicate block = True  -- short enough to duplicate
179
       | numPreds b == 1     = True  -- only one predecessor: go for it
180
       | otherwise           = False
181 182

     numPreds bid = mapLookup bid backEdges `orElse` 0
183

Simon Marlow's avatar
Simon Marlow committed
184
     canShortcut :: CmmBlock -> Maybe BlockId
185
     canShortcut block
Simon Marlow's avatar
Simon Marlow committed
186
       | (_, middle, CmmBranch dest) <- blockSplit block
187 188 189 190 191 192
       , isEmptyBlock middle
       = Just dest
       | otherwise
       = Nothing

     backEdges :: BlockEnv Int -- number of predecessors for each block
Simon Marlow's avatar
Simon Marlow committed
193
     backEdges = mapInsertWith (+) entry_id 1 $ -- add 1 for the entry id
Simon Marlow's avatar
Simon Marlow committed
194
                   predMap blocks
195 196

     splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
Simon Marlow's avatar
Simon Marlow committed
197
     splice head rest = head `blockAppend` snd (blockSplitHead rest)
198 199 200 201 202 203 204


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
205
okToDuplicate :: CmmBlock -> Bool
206
okToDuplicate block
207 208 209 210 211 212 213
  = 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
214

215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243

{-  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
244 245 246
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.
247 248
-}

249 250 251
------------------------------------------------------------------------
-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied BlockEnv.
252 253

replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
254
replaceLabels env g
Simon Marlow's avatar
Simon Marlow committed
255 256
  | mapNull env = g
  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
257
   where
258
     replace_eid g = g {g_entry = lookup (g_entry g)}
259 260 261 262
     lookup id = mapLookup id env `orElse` id

     txnode :: CmmNode e x -> CmmNode e x
     txnode (CmmBranch bid)         = CmmBranch (lookup bid)
263
     txnode (CmmCondBranch p t f)   = mkCmmCondBranch (exp p) (lookup t) (lookup f)
264
     txnode (CmmSwitch e arms)      = CmmSwitch (exp e) (map (liftM lookup) arms)
265
     txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r
266 267 268 269 270
     txnode fc@CmmForeignCall{}     = fc{ args = map exp (args fc)
                                        , succ = lookup (succ fc) }
     txnode other                   = mapExpDeep exp other

     exp :: CmmExpr -> CmmExpr
271
     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
Simon Marlow's avatar
Simon Marlow committed
272
     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
273 274
     exp e                                      = e

Simon Marlow's avatar
Simon Marlow committed
275
mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
276
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
277 278 279

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

Simon Marlow's avatar
Simon Marlow committed
281
predMap :: [CmmBlock] -> BlockEnv Int
282
predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
Simon Marlow's avatar
Simon Marlow committed
283 284 285
  where
    add_preds block env = foldr add env (successors block)
      where add lbl env = mapInsertWith (+) lbl 1 env
286 287 288 289 290

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

291 292 293 294
removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
removeUnreachableBlocksProc (CmmProc info lbl live g)
   = CmmProc info lbl live (removeUnreachableBlocks g)

295
removeUnreachableBlocks :: CmmGraph -> CmmGraph
296 297 298 299
removeUnreachableBlocks g
  | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
  | otherwise = g
  where blocks = postorderDfs g