Merge branch 'master' of http://darcs.haskell.org/ghc
[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 ( cmmCfgOpts
6 , cmmCfgOptsProc
7 , removeUnreachableBlocks
8 , replaceLabels
9 )
10 where
11
12 import BlockId
13 import Cmm
14 import CmmUtils
15 import Maybes
16
17 import Hoopl
18 import Control.Monad
19 import Prelude hiding (succ, unzip, zip)
20
21 -----------------------------------------------------------------------------
22 --
23 -- Control-flow optimisations
24 --
25 -----------------------------------------------------------------------------
26
27 cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
28 cmmCfgOpts split g = fst (blockConcat split g)
29
30 cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
31 cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
32 where (g', env) = blockConcat split g
33 info' = info{ info_tbls = new_info_tbls }
34 new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
35
36 -- If we changed any labels, then we have to update the info tables
37 -- too, except for the top-level info table because that might be
38 -- referred to by other procs.
39 upd_info (k,info)
40 | Just k' <- mapLookup k env
41 = (k', if k' == g_entry g'
42 then info
43 else info{ cit_lbl = infoTblLbl k' })
44 | otherwise
45 = (k,info)
46
47 cmmCfgOptsProc _ top = top
48
49
50 -----------------------------------------------------------------------------
51 --
52 -- Block concatenation
53 --
54 -----------------------------------------------------------------------------
55
56 -- This optimisation does three things:
57 --
58 -- - If a block finishes with an unconditional branch, then we may
59 -- be able to concatenate the block it points to and remove the
60 -- branch. We do this either if the destination block is small
61 -- (e.g. just another branch), or if this is the only jump to
62 -- this particular destination block.
63 --
64 -- - If a block finishes in a call whose continuation block is a
65 -- goto, then we can shortcut the destination, making the
66 -- continuation block the destination of the goto.
67 -- (but see Note [shortcut call returns])
68 --
69 -- - removes any unreachable blocks from the graph. This is a side
70 -- effect of starting with a postorder DFS traversal of the graph
71 --
72
73 -- Both transformations are improved by working from the end of the
74 -- graph towards the beginning, because we may be able to perform many
75 -- shortcuts in one go.
76
77
78 -- We need to walk over the blocks from the end back to the
79 -- beginning. We are going to maintain the "current" graph
80 -- (BlockEnv CmmBlock) as we go, and also a mapping from BlockId
81 -- to BlockId, representing continuation labels that we have
82 -- renamed. This latter mapping is important because we might
83 -- shortcut a CmmCall continuation. For example:
84 --
85 -- Sp[0] = L
86 -- call g returns to L
87 --
88 -- L: goto M
89 --
90 -- M: ...
91 --
92 -- So when we shortcut the L block, we need to replace not only
93 -- the continuation of the call, but also references to L in the
94 -- code (e.g. the assignment Sp[0] = L). So we keep track of
95 -- which labels we have renamed and apply the mapping at the end
96 -- with replaceLabels.
97
98 blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId)
99 blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
100 = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
101 where
102 -- we might be able to shortcut the entry BlockId itself.
103 -- remember to update the shortcut_map', since we also have to
104 -- update the info_tbls mapping now.
105 (new_entry, shortcut_map')
106 | Just entry_blk <- mapLookup entry_id new_blocks
107 , Just dest <- canShortcut entry_blk
108 = (dest, mapInsert entry_id dest shortcut_map)
109 | otherwise
110 = (entry_id, shortcut_map)
111
112 blocks = postorderDfs g
113 blockmap = foldr addBlock emptyBody blocks
114 -- the initial blockmap is constructed from the postorderDfs result,
115 -- so that we automatically throw away unreachable blocks.
116
117 (new_blocks, shortcut_map) =
118 foldr maybe_concat (blockmap, mapEmpty) blocks
119
120 maybe_concat :: CmmBlock
121 -> (BlockEnv CmmBlock, BlockEnv BlockId)
122 -> (BlockEnv CmmBlock, BlockEnv BlockId)
123 maybe_concat block (blocks, shortcut_map)
124 | CmmBranch b' <- last
125 , Just blk' <- mapLookup b' blocks
126 , shouldConcatWith b' blk'
127 = (mapInsert bid (splice head blk') blocks, shortcut_map)
128
129 -- calls: if we can shortcut the continuation label, then
130 -- we must *also* remember to substitute for the label in the
131 -- code, because we will push it somewhere.
132 | splitting_procs -- Note [shortcut call returns]
133 , Just b' <- callContinuation_maybe last
134 , Just blk' <- mapLookup b' blocks
135 , Just dest <- canShortcut blk'
136 = (blocks, mapInsert b' dest shortcut_map)
137 -- replaceLabels will substitute dest for b' everywhere, later
138
139 -- non-calls: see if we can shortcut any of the successors.
140 | Nothing <- callContinuation_maybe last
141 = ( mapInsert bid (blockJoinTail head shortcut_last) blocks
142 , shortcut_map )
143
144 | otherwise
145 = (blocks, shortcut_map)
146 where
147 (head, last) = blockSplitTail block
148 bid = entryLabel block
149 shortcut_last = mapSuccessors shortcut last
150 shortcut l =
151 case mapLookup l blocks of
152 Just b | Just dest <- canShortcut b -> dest
153 _otherwise -> l
154
155 shouldConcatWith b block
156 | okToDuplicate block = True -- short enough to duplicate
157 | num_preds b == 1 = True -- only one predecessor: go for it
158 | otherwise = False
159 where num_preds bid = mapLookup bid backEdges `orElse` 0
160
161 canShortcut :: CmmBlock -> Maybe BlockId
162 canShortcut block
163 | (_, middle, CmmBranch dest) <- blockSplit block
164 , isEmptyBlock middle
165 = Just dest
166 | otherwise
167 = Nothing
168
169 backEdges :: BlockEnv Int -- number of predecessors for each block
170 backEdges = mapInsertWith (+) entry_id 1 $ -- add 1 for the entry id
171 predMap blocks
172
173 splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
174 splice head rest = head `blockAppend` snd (blockSplitHead rest)
175
176
177 callContinuation_maybe :: CmmNode O C -> Maybe BlockId
178 callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
179 callContinuation_maybe (CmmForeignCall { succ = b }) = Just b
180 callContinuation_maybe _ = Nothing
181
182 okToDuplicate :: CmmBlock -> Bool
183 okToDuplicate block
184 = case blockSplit block of
185 (_, m, CmmBranch _) -> isEmptyBlock m
186 -- cheap and cheerful; we might expand this in the future to
187 -- e.g. spot blocks that represent a single instruction or two.
188 -- Be careful: a CmmCall can be more than one instruction, it
189 -- has a CmmExpr inside it.
190 _otherwise -> False
191
192
193 {- Note [shortcut call returns]
194
195 Consider this code that you might get from a recursive let-no-escape:
196
197 goto L1
198 L1:
199 if (Hp > HpLim) then L2 else L3
200 L2:
201 call stg_gc_noregs returns to L4
202 L4:
203 goto L1
204 L3:
205 ...
206 goto L1
207
208 Then the control-flow optimiser shortcuts L4. But that turns L1
209 into the call-return proc point, and every iteration of the loop
210 has to shuffle variables to and from the stack. So we must *not*
211 shortcut L4.
212
213 Moreover not shortcutting call returns is probably fine. If L4 can
214 concat with its branch target then it will still do so. And we
215 save some compile time because we don't have to traverse all the
216 code in replaceLabels.
217
218 However, we probably do want to do this if we are splitting proc
219 points, because L1 will be a proc-point anyway, so merging it with L4
220 reduces the number of proc points. Unfortunately recursive
221 let-no-escapes won't generate very good code with proc-point splitting
222 on - we should probably compile them to explicitly use the native
223 calling convention instead.
224 -}
225
226 ------------------------------------------------------------------------
227 -- Map over the CmmGraph, replacing each label with its mapping in the
228 -- supplied BlockEnv.
229
230 replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
231 replaceLabels env g
232 | mapNull env = g
233 | otherwise = replace_eid $ mapGraphNodes1 txnode g
234 where
235 replace_eid g = g {g_entry = lookup (g_entry g)}
236 lookup id = mapLookup id env `orElse` id
237
238 txnode :: CmmNode e x -> CmmNode e x
239 txnode (CmmBranch bid) = CmmBranch (lookup bid)
240 txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f)
241 txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms)
242 txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r
243 txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
244 , succ = lookup (succ fc) }
245 txnode other = mapExpDeep exp other
246
247 exp :: CmmExpr -> CmmExpr
248 exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
249 exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
250 exp e = e
251
252 mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
253 mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
254
255 ----------------------------------------------------------------
256 -- Build a map from a block to its set of predecessors. Very useful.
257
258 predMap :: [CmmBlock] -> BlockEnv Int
259 predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
260 where
261 add_preds block env = foldr add env (successors block)
262 where add lbl env = mapInsertWith (+) lbl 1 env
263
264 -----------------------------------------------------------------------------
265 --
266 -- Removing unreachable blocks
267
268 removeUnreachableBlocks :: CmmGraph -> CmmGraph
269 removeUnreachableBlocks g
270 | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
271 | otherwise = g
272 where blocks = postorderDfs g