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

4
module CmmContFlowOpt
5 6 7 8
    ( cmmCfgOpts
    , runCmmContFlowOpts
    , 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

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

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

29 30
runCmmContFlowOpts :: CmmGroup -> CmmGroup
runCmmContFlowOpts = map (optProc cmmCfgOpts)
31

32
cmmCfgOpts :: CmmGraph -> CmmGraph
33
cmmCfgOpts = removeUnreachableBlocks . blockConcat
34

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
-- Block concatenation
43 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
-- 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
73
--
74 75 76 77 78 79 80 81 82 83 84
--    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
85
  where
86 87 88 89 90 91 92
     -- 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
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 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
     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)
     maybe_concat block unchanged@(blocks, shortcut_map) =
        | CmmBranch b' <- last
        , Just blk' <- mapLookup b' blocks
        , shouldConcatWith b' blocks
        -> (mapInsert bid (splice head blk') blocks, shortcut_map)

        | Just b'   <- callContinuation_maybe last
        , Just blk' <- mapLookup b' blocks
        , Just dest <- canShortcut b' blk'
        -> (blocks, mapInsert b' dest shortcut_map)
           -- replaceLabels will substitute dest for b' everywhere, later

        | otherwise = unchanged
        where
          (head, last) = blockTail block
          bid = entryLabel b

     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

     canShortcut :: Block C C -> Maybe BlockId
     canShortcut block
       | (_, middle, CmmBranch dest) <- blockHeadTail block
       , isEmptyBlock middle
       = Just dest
       | otherwise
       = Nothing

     backEdges :: BlockEnv Int -- number of predecessors for each block
     backEdges = mapMap setSize $ predMap blocks
                    ToDo: add 1 for the entry id

     splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
     splice head rest = head `cat` snd (blockHead rest)


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

okToDuplicate :: Block C C -> Bool
okToDuplicate block
  = case blockToNodeList block of (_, m, _) -> null m
  -- 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.
155 156

replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
157 158 159
replaceLabels env g
  | isEmptyMap env = g
  | otherwise      = replace_eid . mapGraphNodes1 txnode
160
   where
161
     replace_eid g = g {g_entry = lookup (g_entry g)}
162 163 164 165
     lookup id = mapLookup id env `orElse` id

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

178 179
mkCmmCondBranch :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
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
180 181 182

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

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


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

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