finish a comment
[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 g) = CmmProc info' lbl 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 new_entry
104 | Just entry_blk <- mapLookup entry_id new_blocks
105 , Just dest <- canShortcut entry_blk
106 = dest
107 | otherwise
108 = entry_id
109
110 blocks = postorderDfs g
111 blockmap = foldr addBlock emptyBody blocks
112 -- the initial blockmap is constructed from the postorderDfs result,
113 -- so that we automatically throw away unreachable blocks.
114
115 (new_blocks, shortcut_map) =
116 foldr maybe_concat (blockmap, mapEmpty) blocks
117
118 maybe_concat :: CmmBlock
119 -> (BlockEnv CmmBlock, BlockEnv BlockId)
120 -> (BlockEnv CmmBlock, BlockEnv BlockId)
121 maybe_concat block (blocks, shortcut_map)
122 | CmmBranch b' <- last
123 , Just blk' <- mapLookup b' blocks
124 , shouldConcatWith b' blk'
125 = (mapInsert bid (splice head blk') blocks, shortcut_map)
126
127 -- calls: if we can shortcut the continuation label, then
128 -- we must *also* remember to substitute for the label in the
129 -- code, because we will push it somewhere.
130 | splitting_procs -- Note [shortcut call returns]
131 , Just b' <- callContinuation_maybe last
132 , Just blk' <- mapLookup b' blocks
133 , Just dest <- canShortcut blk'
134 = (blocks, mapInsert b' dest shortcut_map)
135 -- replaceLabels will substitute dest for b' everywhere, later
136
137 -- non-calls: see if we can shortcut any of the successors.
138 | Nothing <- callContinuation_maybe last
139 = ( mapInsert bid (blockJoinTail head shortcut_last) blocks
140 , shortcut_map )
141
142 | otherwise
143 = (blocks, shortcut_map)
144 where
145 (head, last) = blockSplitTail block
146 bid = entryLabel block
147 shortcut_last = mapSuccessors shortcut last
148 shortcut l =
149 case mapLookup l blocks of
150 Just b | Just dest <- canShortcut b -> dest
151 _otherwise -> l
152
153 shouldConcatWith b block
154 | num_preds b == 1 = True -- only one predecessor: go for it
155 | okToDuplicate block = True -- short enough to duplicate
156 | otherwise = False
157 where num_preds bid = mapLookup bid backEdges `orElse` 0
158
159 canShortcut :: CmmBlock -> Maybe BlockId
160 canShortcut block
161 | (_, middle, CmmBranch dest) <- blockSplit block
162 , isEmptyBlock middle
163 = Just dest
164 | otherwise
165 = Nothing
166
167 backEdges :: BlockEnv Int -- number of predecessors for each block
168 backEdges = mapInsertWith (+) entry_id 1 $ -- add 1 for the entry id
169 mapMap setSize $ predMap blocks
170
171 splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
172 splice head rest = head `blockAppend` snd (blockSplitHead rest)
173
174
175 callContinuation_maybe :: CmmNode O C -> Maybe BlockId
176 callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
177 callContinuation_maybe (CmmForeignCall { succ = b }) = Just b
178 callContinuation_maybe _ = Nothing
179
180 okToDuplicate :: CmmBlock -> Bool
181 okToDuplicate block
182 = case blockSplit block of
183 (_, m, CmmBranch _) -> isEmptyBlock m
184 -- cheap and cheerful; we might expand this in the future to
185 -- e.g. spot blocks that represent a single instruction or two.
186 -- Be careful: a CmmCall can be more than one instruction, it
187 -- has a CmmExpr inside it.
188 _otherwise -> False
189
190
191 {- Note [shortcut call returns]
192
193 Consider this code that you might get from a recursive let-no-escape:
194
195 goto L1
196 L1:
197 if (Hp > HpLim) then L2 else L3
198 L2:
199 call stg_gc_noregs returns to L4
200 L4:
201 goto L1
202 L3:
203 ...
204 goto L1
205
206 Then the control-flow optimiser shortcuts L4. But that turns L1
207 into the call-return proc point, and every iteration of the loop
208 has to shuffle variables to and from the stack. So we must *not*
209 shortcut L4.
210
211 Moreover not shortcutting call returns is probably fine. If L4 can
212 concat with its branch target then it will still do so. And we
213 save some compile time because we don't have to traverse all the
214 code in replaceLabels.
215
216 However, we probably do want to do this if we are splitting proc
217 points, because L1 will be a proc-point anyway, so merging it with L4
218 reduces the number of proc points. Unfortunately recursive
219 let-no-escapes won't generate very good code with proc-point splitting
220 on - we should probably compile them to explicitly use the native
221 calling convention instead.
222 -}
223
224 ------------------------------------------------------------------------
225 -- Map over the CmmGraph, replacing each label with its mapping in the
226 -- supplied BlockEnv.
227
228 replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
229 replaceLabels env g
230 | mapNull env = g
231 | otherwise = replace_eid $ mapGraphNodes1 txnode g
232 where
233 replace_eid g = g {g_entry = lookup (g_entry g)}
234 lookup id = mapLookup id env `orElse` id
235
236 txnode :: CmmNode e x -> CmmNode e x
237 txnode (CmmBranch bid) = CmmBranch (lookup bid)
238 txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f)
239 txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms)
240 txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r
241 txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
242 , succ = lookup (succ fc) }
243 txnode other = mapExpDeep exp other
244
245 exp :: CmmExpr -> CmmExpr
246 exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
247 exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
248 exp e = e
249
250 mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
251 mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
252
253 ----------------------------------------------------------------
254 -- Build a map from a block to its set of predecessors. Very useful.
255
256 predMap :: [CmmBlock] -> BlockEnv BlockSet
257 predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
258 where add_preds block env = foldl (add (entryLabel block)) env (successors block)
259 add bid env b' =
260 mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
261
262
263 -----------------------------------------------------------------------------
264 --
265 -- Removing unreachable blocks
266
267 removeUnreachableBlocks :: CmmGraph -> CmmGraph
268 removeUnreachableBlocks g
269 | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
270 | otherwise = g
271 where blocks = postorderDfs g