Merge branch 'master' into type-nats
[ghc.git] / compiler / cmm / CmmContFlowOpt.hs
1 {-# LANGUAGE GADTs #-}
2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
3
4 module CmmContFlowOpt
5 ( runCmmOpts, oldCmmCfgOpts, cmmCfgOpts
6 , branchChainElim, removeUnreachableBlocks, predMap
7 , replaceLabels, replaceBranches, runCmmContFlowOpts
8 )
9 where
10
11 import BlockId
12 import Cmm
13 import CmmDecl
14 import CmmExpr
15 import qualified OldCmm as Old
16
17 import Maybes
18 import Compiler.Hoopl
19 import Control.Monad
20 import Outputable
21 import Prelude hiding (succ, unzip, zip)
22 import Util
23
24 ------------------------------------
25 runCmmContFlowOpts :: Cmm -> Cmm
26 runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog
27
28 oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
29 cmmCfgOpts :: CmmGraph -> CmmGraph
30
31 oldCmmCfgOpts = oldBranchChainElim -- boring, but will get more exciting later
32 cmmCfgOpts =
33 removeUnreachableBlocks . blockConcat . branchChainElim
34 -- Here branchChainElim can ultimately be replaced
35 -- with a more exciting combination of optimisations
36
37 runCmmOpts :: (g -> g) -> GenCmm d h g -> GenCmm d h g
38 -- Lifts a transformer on a single graph to one on the whole program
39 runCmmOpts opt = mapProcs (optProc opt)
40
41 optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g
42 optProc _ top@(CmmData {}) = top
43 optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
44
45 ------------------------------------
46 mapProcs :: (GenCmmTop d h s -> GenCmmTop d h s) -> GenCmm d h s -> GenCmm d h s
47 mapProcs f (Cmm tops) = Cmm (map f tops)
48
49 ----------------------------------------------------------------
50 oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
51 -- If L is not captured in an instruction, we can remove any
52 -- basic block of the form L: goto L', and replace L with L' everywhere else.
53 -- 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 where
60 (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
61 new_blocks = map (replaceLabels env) others
62 env = mkClosureBlockEnv lone_branch_blocks
63
64 isLoneBranch :: Old.CmmBasicBlock -> Either (BlockId, BlockId) Old.CmmBasicBlock
65 isLoneBranch (Old.BasicBlock id [Old.CmmBranch target]) | id /= target = Left (id, target)
66 isLoneBranch other_block = Right other_block
67 -- An infinite loop is not a link in a branch chain!
68
69 replaceLabels :: BlockEnv BlockId -> Old.CmmBasicBlock -> Old.CmmBasicBlock
70 replaceLabels env (Old.BasicBlock id stmts)
71 = Old.BasicBlock id (map replace stmts)
72 where
73 replace (Old.CmmBranch id) = Old.CmmBranch (lookup id)
74 replace (Old.CmmCondBranch e id) = Old.CmmCondBranch e (lookup id)
75 replace (Old.CmmSwitch e tbl) = Old.CmmSwitch e (map (fmap lookup) tbl)
76 replace other_stmt = other_stmt
77
78 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 -- and replace L with L' everywhere else,
84 -- unless L is the successor of a call instruction and L'
85 -- is the entry block. You don't want to set the successor
86 -- of a function call to the entry block because there is no good way
87 -- to store both the infotables for the call and from the callee,
88 -- while putting the stack pointer in a consistent place.
89 --
90 -- JD isn't quite sure when it's safe to share continuations for different
91 -- function calls -- have to think about where the SP will be,
92 -- 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 blocks = toBlockList g
100 (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
101 env = mkClosureBlockEnv lone_branch_blocks
102 self_branches =
103 let loop_to (id, _) =
104 if lookup id == id then
105 Just $ blockOfNodeList (JustC (CmmEntry id), [], JustC (mkBranchNode id))
106 else
107 Nothing
108 in mapMaybe loop_to lone_branch_blocks
109 lookup id = mapLookup id env `orElse` id
110
111 call_succs = foldl add emptyBlockSet blocks
112 where add :: BlockSet -> CmmBlock -> BlockSet
113 add succs b =
114 case lastNode b of
115 (CmmCall _ (Just k) _ _ _) -> setInsert k succs
116 (CmmForeignCall {succ=k}) -> setInsert k succs
117 _ -> succs
118 isLoneBranch :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
119 isLoneBranch block | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block,
120 id /= target && not (setMember id call_succs)
121 = Left (id,target)
122 isLoneBranch other = Right other
123 -- An infinite loop is not a link in a branch chain!
124
125 maybeReplaceLabels :: (CmmNode O C -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
126 maybeReplaceLabels lpred env =
127 replace_eid . mapGraphNodes (id, middle, last)
128 where
129 replace_eid g = g {g_entry = lookup (g_entry g)}
130 lookup id = fmap lookup (mapLookup id env) `orElse` id
131
132 middle = mapExpDeep exp
133 last l = if lpred l then mapExpDeep exp (last' l) else l
134 last' :: CmmNode O C -> CmmNode O C
135 last' (CmmBranch bid) = CmmBranch (lookup bid)
136 last' (CmmCondBranch p t f) = CmmCondBranch p (lookup t) (lookup f)
137 last' (CmmSwitch e arms) = CmmSwitch e (map (liftM lookup) arms)
138 last' (CmmCall t k a res r) = CmmCall t (liftM lookup k) a res r
139 last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (lookup bid) u i
140
141 exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
142 exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
143 exp e = e
144
145
146 replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
147 replaceLabels = maybeReplaceLabels (const True)
148
149 replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
150 replaceBranches env g = mapGraphNodes (id, id, last) g
151 where
152 last :: CmmNode O C -> CmmNode O C
153 last (CmmBranch id) = CmmBranch (lookup id)
154 last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
155 last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
156 last l@(CmmCall {}) = l
157 last l@(CmmForeignCall {}) = l
158 lookup id = fmap lookup (mapLookup id env) `orElse` id
159
160 ----------------------------------------------------------------
161 -- Build a map from a block to its set of predecessors. Very useful.
162 predMap :: [CmmBlock] -> BlockEnv BlockSet
163 predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
164 where add_preds block env = foldl (add (entryLabel block)) env (successors block)
165 add bid env b' =
166 mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
167 ----------------------------------------------------------------
168 -- If a block B branches to a label L, L is not the entry block,
169 -- and L has no other predecessors,
170 -- then we can splice the block starting with L onto the end of B.
171 -- Order matters, so we work bottom up (reverse postorder DFS).
172 -- This optimization can be inhibited by unreachable blocks, but
173 -- 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 --
178 -- Note: This optimization does _not_ subsume branch chain elimination.
179 blockConcat :: CmmGraph -> CmmGraph
180 blockConcat g@(CmmGraph {g_entry=eid}) =
181 replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
182 where blocks = postorderDfs g
183 (blocks', concatMap) =
184 foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
185 maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
186 maybe_concat b unchanged@(blocks', concatMap) =
187 let bid = entryLabel b
188 in case blockToNodeList b of
189 (JustC h, m, JustC (CmmBranch b')) ->
190 if canConcatWith b' then
191 (mapInsert bid (splice blocks' h m b') blocks',
192 mapInsert b' bid concatMap)
193 else unchanged
194 _ -> unchanged
195 num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0
196 canConcatWith b' = b' /= eid && num_preds b' == 1
197 backEdges = predMap blocks
198 splice :: forall map n e x.
199 IsMap map =>
200 map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
201 splice blocks' h m bid' =
202 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 mkClosureBlockEnv blocks = mapFromList $ map follow blocks
208 where singleEnv = mapFromList blocks :: BlockEnv BlockId
209 follow (id, next) = (id, endChain id next)
210 endChain orig id = case mapLookup id singleEnv of
211 Just id' | id /= orig -> endChain orig id'
212 _ -> id
213 ----------------------------------------------------------------
214 removeUnreachableBlocks :: CmmGraph -> CmmGraph
215 removeUnreachableBlocks g =
216 if length blocks < mapSize (toBlockMap g) then ofBlockList (g_entry g) blocks
217 else g
218 where blocks = postorderDfs g