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

4
module CmmContFlowOpt
5 6 7
    ( runCmmOpts, oldCmmCfgOpts, cmmCfgOpts
    , branchChainElim, removeUnreachableBlocks, predMap
    , replaceLabels, replaceBranches, runCmmContFlowOpts
8 9 10
    )
where

11
import BlockId
12
import Cmm
13 14 15
import CmmDecl
import CmmExpr
import qualified OldCmm as Old
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
16

17
import Maybes
18
import Compiler.Hoopl
Ian Lynagh's avatar
Ian Lynagh committed
19
import Control.Monad
20
import Outputable
21
import Prelude hiding (succ, unzip, zip)
22 23 24
import Util

------------------------------------
25 26 27 28 29 30 31 32 33
runCmmContFlowOpts :: Cmm -> Cmm
runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog

oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
cmmCfgOpts    :: CmmGraph -> CmmGraph

oldCmmCfgOpts = oldBranchChainElim  -- boring, but will get more exciting later
cmmCfgOpts    =
  removeUnreachableBlocks . blockConcat . branchChainElim
34 35 36
        -- Here branchChainElim can ultimately be replaced
        -- with a more exciting combination of optimisations

37
runCmmOpts :: (g -> g) -> GenCmm d h g -> GenCmm d h g
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
38
-- Lifts a transformer on a single graph to one on the whole program
39
runCmmOpts opt = mapProcs (optProc opt)
40

41 42 43
optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g
optProc _   top@(CmmData {}) = top
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
44

45
------------------------------------
46 47
mapProcs :: (GenCmmTop d h s -> GenCmmTop d h s) -> GenCmm d h s -> GenCmm d h s
mapProcs f (Cmm tops) = Cmm (map f tops)
48

49
----------------------------------------------------------------
50
oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
51 52 53
-- If L is not captured in an instruction, we can remove any
-- basic block of the form L: goto L', and replace L with L' everywhere else.
-- How does L get captured? In a CallArea.
54
oldBranchChainElim (Old.ListGraph blocks)
55
  | null lone_branch_blocks     -- No blocks to remove
56
  = Old.ListGraph blocks
57
  | otherwise
58
  = Old.ListGraph new_blocks
59 60 61 62 63
  where
    (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
    new_blocks = map (replaceLabels env) others
    env = mkClosureBlockEnv lone_branch_blocks

64 65 66 67
    isLoneBranch :: Old.CmmBasicBlock -> Either (BlockId, BlockId) Old.CmmBasicBlock
    isLoneBranch (Old.BasicBlock id [Old.CmmBranch target]) | id /= target = Left (id, target)
    isLoneBranch other_block                                           = Right other_block
       -- An infinite loop is not a link in a branch chain!
68

69 70 71 72 73 74 75 76 77 78
    replaceLabels :: BlockEnv BlockId -> Old.CmmBasicBlock -> Old.CmmBasicBlock
    replaceLabels env (Old.BasicBlock id stmts)
      = Old.BasicBlock id (map replace stmts)
      where
        replace (Old.CmmBranch id)       = Old.CmmBranch (lookup id)
        replace (Old.CmmCondBranch e id) = Old.CmmCondBranch e (lookup id)
        replace (Old.CmmSwitch e tbl)    = Old.CmmSwitch e (map (fmap lookup) tbl)
        replace other_stmt           = other_stmt

        lookup id = mapLookup id env `orElse` id 
79 80

----------------------------------------------------------------
81
branchChainElim :: CmmGraph -> CmmGraph
82
-- Remove any basic block of the form L: goto L',
83 84 85 86 87 88 89 90 91 92
-- and replace L with L' everywhere else,
-- unless L is the successor of a call instruction and L'
-- is the entry block. You don't want to set the successor
-- of a function call to the entry block because there is no good way
-- to store both the infotables for the call and from the callee,
-- while putting the stack pointer in a consistent place.
--
-- JD isn't quite sure when it's safe to share continuations for different
-- function calls -- have to think about where the SP will be,
-- so we'll table that problem for now by leaving all call successors alone.
93
branchChainElim g
94
  | null lone_branch_blocks     -- No blocks to remove
95
  = g
96
  | otherwise
97
  = replaceLabels env $ ofBlockList (g_entry g) (self_branches ++ others)
98
  where
99 100 101
    blocks = toBlockList g
    (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
    env = mkClosureBlockEnv lone_branch_blocks
102
    self_branches =
103 104
      let loop_to (id, _) =
            if lookup id == id then
105
              Just $ blockOfNodeList (JustC (CmmEntry id), [], JustC (mkBranchNode id))
106 107 108
            else
              Nothing
      in  mapMaybe loop_to lone_branch_blocks
109
    lookup id = mapLookup id env `orElse` id
110

111
    call_succs = foldl add emptyBlockSet blocks
112 113 114 115 116 117 118 119 120 121 122
      where add :: BlockSet -> CmmBlock -> BlockSet
            add succs b =
              case lastNode b of
                (CmmCall _ (Just k) _ _ _) -> setInsert k succs
                (CmmForeignCall {succ=k})  -> setInsert k succs
                _                          -> succs
    isLoneBranch :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
    isLoneBranch block | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block,
                         id /= target && not (setMember id call_succs)
                       = Left (id,target)
    isLoneBranch other = Right other
123 124
       -- An infinite loop is not a link in a branch chain!

125
maybeReplaceLabels :: (CmmNode O C -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
126
maybeReplaceLabels lpred env =
127
  replace_eid . mapGraphNodes (id, middle, last)
128
   where
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
     replace_eid g = g {g_entry = lookup (g_entry g)}
     lookup id = fmap lookup (mapLookup id env) `orElse` id
     
     middle = mapExpDeep exp
     last l = if lpred l then mapExpDeep exp (last' l) else l
     last' :: CmmNode O C -> CmmNode O C
     last' (CmmBranch bid)             = CmmBranch (lookup bid)
     last' (CmmCondBranch p t f)       = CmmCondBranch p (lookup t) (lookup f)
     last' (CmmSwitch e arms)          = CmmSwitch e (map (liftM lookup) arms)
     last' (CmmCall t k a res r)       = CmmCall t (liftM lookup k) a res r
     last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (lookup bid) u i

     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
     exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
     exp e                                      = e


replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceLabels = maybeReplaceLabels (const True)
148 149

replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
150
replaceBranches env g = mapGraphNodes (id, id, last) g
151
  where
152 153 154 155 156 157 158
    last :: CmmNode O C -> CmmNode O C
    last (CmmBranch id)          = CmmBranch (lookup id)
    last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
    last (CmmSwitch e tbl)       = CmmSwitch e (map (fmap lookup) tbl)
    last l@(CmmCall {})          = l
    last l@(CmmForeignCall {})   = l
    lookup id = fmap lookup (mapLookup id env) `orElse` id
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
159 160 161

----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful.
162 163 164 165 166
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
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
167
----------------------------------------------------------------
168 169
-- If a block B branches to a label L, L is not the entry block,
-- and L has no other predecessors,
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
170 171
-- then we can splice the block starting with L onto the end of B.
-- Order matters, so we work bottom up (reverse postorder DFS).
172 173
-- This optimization can be inhibited by unreachable blocks, but
-- the reverse postorder DFS returns only reachable blocks.
174 175
--
-- To ensure correctness, we have to make sure that the BlockId of the block
176
-- we are about to eliminate is not named in another instruction.
177
--
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
178
-- Note: This optimization does _not_ subsume branch chain elimination.
179 180 181 182 183 184 185 186 187 188 189
blockConcat  :: CmmGraph -> CmmGraph
blockConcat g@(CmmGraph {g_entry=eid}) =
  replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
  where blocks = postorderDfs g
        (blocks', concatMap) =
           foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
        maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
        maybe_concat b unchanged@(blocks', concatMap) =
          let bid = entryLabel b
          in case blockToNodeList b of
               (JustC h, m, JustC (CmmBranch b')) ->
190
                  if canConcatWith b' then
191 192
                    (mapInsert bid (splice blocks' h m b') blocks',
                     mapInsert b' bid concatMap)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
193 194
                  else unchanged
               _ -> unchanged
195
        num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0
196
        canConcatWith b' = b' /= eid && num_preds b' == 1
197 198 199 200 201 202
        backEdges = predMap blocks
        splice :: forall map n e x.
                  IsMap map =>
                  map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
        splice blocks' h m bid' =
          case mapLookup bid' blocks' of
203
            Nothing -> panic "unknown successor block"
204
            Just block | (_, m', l') <- blockToNodeList block -> blockOfNodeList (JustC h, (m ++ m'), l')
205 206
----------------------------------------------------------------
mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
207 208
mkClosureBlockEnv blocks = mapFromList $ map follow blocks
    where singleEnv = mapFromList blocks :: BlockEnv BlockId
209
          follow (id, next) = (id, endChain id next)
210
          endChain orig id = case mapLookup id singleEnv of
211 212
                               Just id' | id /= orig -> endChain orig id'
                               _ -> id
213
----------------------------------------------------------------
214 215 216 217 218
removeUnreachableBlocks :: CmmGraph -> CmmGraph
removeUnreachableBlocks g =
  if length blocks < mapSize (toBlockMap g) then ofBlockList (g_entry g) blocks
                                           else g
    where blocks = postorderDfs g