CmmContFlowOpt.hs 9.53 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
import CmmUtils
14
import qualified OldCmm as Old
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
15

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

------------------------------------
Simon Peyton Jones's avatar
Simon Peyton Jones committed
24
runCmmContFlowOpts :: CmmGroup -> CmmGroup
25 26 27 28 29 30 31 32
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
33 34 35
        -- Here branchChainElim can ultimately be replaced
        -- with a more exciting combination of optimisations

Simon Peyton Jones's avatar
Simon Peyton Jones committed
36
runCmmOpts :: (g -> g) -> GenCmmGroup d h g -> GenCmmGroup d h g
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
37
-- Lifts a transformer on a single graph to one on the whole program
38
runCmmOpts opt = map (optProc opt)
39

Simon Peyton Jones's avatar
Simon Peyton Jones committed
40
optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
41 42
optProc _   top@(CmmData {}) = top
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
43 44

----------------------------------------------------------------
45
oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
46 47 48
-- 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.
49
oldBranchChainElim (Old.ListGraph blocks)
50
  | null lone_branch_blocks     -- No blocks to remove
51
  = Old.ListGraph blocks
52
  | otherwise
53
  = Old.ListGraph new_blocks
54 55 56 57 58
  where
    (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
    new_blocks = map (replaceLabels env) others
    env = mkClosureBlockEnv lone_branch_blocks

59 60 61 62
    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!
63

64 65 66 67 68 69 70 71 72 73
    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 
74 75

----------------------------------------------------------------
76
branchChainElim :: CmmGraph -> CmmGraph
77
-- Remove any basic block of the form L: goto L',
78 79 80 81 82 83 84 85 86 87
-- 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.
88
branchChainElim g
89
  | null lone_branch_blocks     -- No blocks to remove
90
  = g
91
  | otherwise
92
  = replaceLabels env $ ofBlockList (g_entry g) (self_branches ++ others)
93
  where
94 95 96
    blocks = toBlockList g
    (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
    env = mkClosureBlockEnv lone_branch_blocks
97
    self_branches =
98 99
      let loop_to (id, _) =
            if lookup id == id then
100
              Just $ blockOfNodeList (JustC (CmmEntry id), [], JustC (mkBranchNode id))
101 102 103
            else
              Nothing
      in  mapMaybe loop_to lone_branch_blocks
104
    lookup id = mapLookup id env `orElse` id
105

106
    call_succs = foldl add emptyBlockSet blocks
107 108 109 110 111 112 113 114 115 116 117
      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
118 119
       -- An infinite loop is not a link in a branch chain!

120
maybeReplaceLabels :: (CmmNode O C -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
121
maybeReplaceLabels lpred env =
122
  replace_eid . mapGraphNodes (id, middle, last)
123
   where
124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
     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)
143 144

replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
145
replaceBranches env g = mapGraphNodes (id, id, last) g
146
  where
147 148 149 150 151 152 153
    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
154 155 156

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