CmmContFlowOpt.hs 7.07 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 Digraph
16
import Maybes
17 18
import Outputable

Simon Marlow's avatar
Simon Marlow committed
19
import Hoopl
Ian Lynagh's avatar
Ian Lynagh committed
20
import Control.Monad
21
import Prelude hiding (succ, unzip, zip)
Simon Marlow's avatar
Simon Marlow committed
22
import qualified Data.IntMap as Map
23

24 25 26 27 28
-----------------------------------------------------------------------------
--
-- Control-flow optimisations
--
-----------------------------------------------------------------------------
29

30
cmmCfgOpts :: CmmGraph -> CmmGraph
31
cmmCfgOpts = removeUnreachableBlocks . blockConcat
32

Simon Marlow's avatar
Simon Marlow committed
33 34 35
cmmCfgOptsProc :: CmmDecl -> CmmDecl
cmmCfgOptsProc = optProc cmmCfgOpts

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

40

41 42
-----------------------------------------------------------------------------
--
43
-- Block concatenation
44 45 46
--
-----------------------------------------------------------------------------

47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
-- This optimisation does two things:
--   - 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.
--
-- 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
74
--
75 76 77 78 79 80 81 82 83 84 85
--    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.

blockConcat  :: CmmGraph -> CmmGraph
blockConcat g@CmmGraph { g_entry = entry_id }
  = replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks
86
  where
87 88 89 90 91 92 93
     -- 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
94

95 96 97 98 99 100 101 102
     blocks = postorderDfs g

     (new_blocks, shortcut_map) =
           foldr maybe_concat (toBlockMap g, mapEmpty) blocks

     maybe_concat :: CmmBlock
                  -> (BlockEnv CmmBlock, BlockEnv BlockId)
                  -> (BlockEnv CmmBlock, BlockEnv BlockId)
Simon Marlow's avatar
Simon Marlow committed
103
     maybe_concat block unchanged@(blocks, shortcut_map)
104 105
        | CmmBranch b' <- last
        , Just blk' <- mapLookup b' blocks
Simon Marlow's avatar
Simon Marlow committed
106 107
        , shouldConcatWith b' blk'
        = (mapInsert bid (splice head blk') blocks, shortcut_map)
108 109 110

        | Just b'   <- callContinuation_maybe last
        , Just blk' <- mapLookup b' blocks
Simon Marlow's avatar
Simon Marlow committed
111 112
        , Just dest <- canShortcut blk'
        = (blocks, mapInsert b' dest shortcut_map)
113 114 115 116
           -- replaceLabels will substitute dest for b' everywhere, later

        | otherwise = unchanged
        where
Simon Marlow's avatar
Simon Marlow committed
117 118
          (head, last) = blockSplitTail block
          bid = entryLabel block
119 120 121 122 123 124 125

     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
126
     canShortcut :: CmmBlock -> Maybe BlockId
127
     canShortcut block
Simon Marlow's avatar
Simon Marlow committed
128
       | (_, middle, CmmBranch dest) <- blockSplit block
129 130 131 132 133 134
       , isEmptyBlock middle
       = Just dest
       | otherwise
       = Nothing

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

     splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
Simon Marlow's avatar
Simon Marlow committed
139
     splice head rest = head `blockAppend` snd (blockSplitHead rest)
140 141 142 143 144 145 146


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
147
okToDuplicate :: CmmBlock -> Bool
148
okToDuplicate block
Simon Marlow's avatar
Simon Marlow committed
149
  = case blockSplit block of (_, m, _) -> isEmptyBlock m
150 151 152 153 154 155
  -- cheap and cheerful; we might expand this in the future to
  -- e.g. spot blocks that represent a single instruction or two

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

replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
158
replaceLabels env g
Simon Marlow's avatar
Simon Marlow committed
159 160
  | mapNull env = g
  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
161
   where
162
     replace_eid g = g {g_entry = lookup (g_entry g)}
163 164 165 166
     lookup id = mapLookup id env `orElse` id

     txnode :: CmmNode e x -> CmmNode e x
     txnode (CmmBranch bid)         = CmmBranch (lookup bid)
167
     txnode (CmmCondBranch p t f)   = mkCmmCondBranch (exp p) (lookup t) (lookup f)
168 169 170 171 172 173 174
     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
175 176 177 178
     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
     exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
     exp e                                      = e

Simon Marlow's avatar
Simon Marlow committed
179
mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
180
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
181 182 183

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

185 186 187 188 189
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
190 191 192 193 194 195


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

196
removeUnreachableBlocks :: CmmGraph -> CmmGraph
197 198 199 200
removeUnreachableBlocks g
  | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
  | otherwise = g
  where blocks = postorderDfs g