New codegen: do not split proc-points when using the NCG
[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 :: CmmGraph -> CmmGraph
28 cmmCfgOpts g = removeUnreachableBlocks $ fst (blockConcat g)
29
30 cmmCfgOptsProc :: CmmDecl -> CmmDecl
31 cmmCfgOptsProc (CmmProc info lbl g) = CmmProc info' lbl (removeUnreachableBlocks g')
32 where (g', env) = blockConcat g
33 info' = info{ info_tbls = new_info_tbls }
34 new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
35
36 upd_info (k,info)
37 | Just k' <- mapLookup k env
38 = (k', info{ cit_lbl = infoTblLbl k' })
39 | otherwise
40 = (k,info)
41
42 cmmCfgOptsProc top = top
43
44
45 -----------------------------------------------------------------------------
46 --
47 -- Block concatenation
48 --
49 -----------------------------------------------------------------------------
50
51 -- This optimisation does three things:
52 -- - If a block finishes with an unconditional branch, then we may
53 -- be able to concatenate the block it points to and remove the
54 -- branch. We do this either if the destination block is small
55 -- (e.g. just another branch), or if this is the only jump to
56 -- this particular destination block.
57 --
58 -- - If a block finishes in a call whose continuation block is a
59 -- goto, then we can shortcut the destination, making the
60 -- continuation block the destination of the goto.
61 --
62 -- - removes any unreachable blocks from the graph. This is a side
63 -- effect of starting with a postorder DFS traversal of the graph
64 --
65
66 -- Both transformations are improved by working from the end of the
67 -- graph towards the beginning, because we may be able to perform many
68 -- shortcuts in one go.
69
70
71 -- We need to walk over the blocks from the end back to the
72 -- beginning. We are going to maintain the "current" graph
73 -- (BlockEnv CmmBlock) as we go, and also a mapping from BlockId
74 -- to BlockId, representing continuation labels that we have
75 -- renamed. This latter mapping is important because we might
76 -- shortcut a CmmCall continuation. For example:
77 --
78 -- Sp[0] = L
79 -- call g returns to L
80 --
81 -- L: goto M
82 --
83 -- M: ...
84 --
85 -- So when we shortcut the L block, we need to replace not only
86 -- the continuation of the call, but also references to L in the
87 -- code (e.g. the assignment Sp[0] = L). So we keep track of
88 -- which labels we have renamed and apply the mapping at the end
89 -- with replaceLabels.
90
91 blockConcat :: CmmGraph -> (CmmGraph, BlockEnv BlockId)
92 blockConcat g@CmmGraph { g_entry = entry_id }
93 = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map)
94 where
95 -- we might be able to shortcut the entry BlockId itself
96 new_entry
97 | Just entry_blk <- mapLookup entry_id new_blocks
98 , Just dest <- canShortcut entry_blk
99 = dest
100 | otherwise
101 = entry_id
102
103 blocks = postorderDfs g
104 blockmap = foldr addBlock emptyBody blocks
105 -- the initial blockmap is constructed from the postorderDfs result,
106 -- so that we automatically throw away unreachable blocks.
107
108 (new_blocks, shortcut_map) =
109 foldr maybe_concat (blockmap, mapEmpty) blocks
110
111 maybe_concat :: CmmBlock
112 -> (BlockEnv CmmBlock, BlockEnv BlockId)
113 -> (BlockEnv CmmBlock, BlockEnv BlockId)
114 maybe_concat block (blocks, shortcut_map)
115 | CmmBranch b' <- last
116 , Just blk' <- mapLookup b' blocks
117 , shouldConcatWith b' blk'
118 = (mapInsert bid (splice head blk') blocks, shortcut_map)
119
120 -- calls: if we can shortcut the continuation label, then
121 -- we must *also* remember to substitute for the label in the
122 -- code, because we will push it somewhere.
123 | Just b' <- callContinuation_maybe last
124 , Just blk' <- mapLookup b' blocks
125 , Just dest <- canShortcut blk'
126 = (blocks, mapInsert b' dest shortcut_map)
127 -- replaceLabels will substitute dest for b' everywhere, later
128
129 -- non-calls: see if we can shortcut any of the successors.
130 | Nothing <- callContinuation_maybe last
131 = ( mapInsert bid (blockJoinTail head shortcut_last) blocks
132 , shortcut_map )
133
134 | otherwise
135 = (blocks, shortcut_map)
136 where
137 (head, last) = blockSplitTail block
138 bid = entryLabel block
139 shortcut_last = mapSuccessors shortcut last
140 shortcut l =
141 case mapLookup l blocks of
142 Just b | Just dest <- canShortcut b -> dest
143 _otherwise -> l
144
145 shouldConcatWith b block
146 | num_preds b == 1 = True -- only one predecessor: go for it
147 | okToDuplicate block = True -- short enough to duplicate
148 | otherwise = False
149 where num_preds bid = mapLookup bid backEdges `orElse` 0
150
151 canShortcut :: CmmBlock -> Maybe BlockId
152 canShortcut block
153 | (_, middle, CmmBranch dest) <- blockSplit block
154 , isEmptyBlock middle
155 = Just dest
156 | otherwise
157 = Nothing
158
159 backEdges :: BlockEnv Int -- number of predecessors for each block
160 backEdges = mapInsertWith (+) entry_id 1 $ -- add 1 for the entry id
161 mapMap setSize $ predMap blocks
162
163 splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
164 splice head rest = head `blockAppend` snd (blockSplitHead rest)
165
166
167 callContinuation_maybe :: CmmNode O C -> Maybe BlockId
168 callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
169 callContinuation_maybe (CmmForeignCall { succ = b }) = Just b
170 callContinuation_maybe _ = Nothing
171
172 okToDuplicate :: CmmBlock -> Bool
173 okToDuplicate block
174 = case blockSplit block of
175 (_, m, CmmBranch _) -> isEmptyBlock m
176 -- cheap and cheerful; we might expand this in the future to
177 -- e.g. spot blocks that represent a single instruction or two.
178 -- Be careful: a CmmCall can be more than one instruction, it
179 -- has a CmmExpr inside it.
180 _otherwise -> False
181
182 ------------------------------------------------------------------------
183 -- Map over the CmmGraph, replacing each label with its mapping in the
184 -- supplied BlockEnv.
185
186 replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
187 replaceLabels env g
188 | mapNull env = g
189 | otherwise = replace_eid $ mapGraphNodes1 txnode g
190 where
191 replace_eid g = g {g_entry = lookup (g_entry g)}
192 lookup id = mapLookup id env `orElse` id
193
194 txnode :: CmmNode e x -> CmmNode e x
195 txnode (CmmBranch bid) = CmmBranch (lookup bid)
196 txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f)
197 txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms)
198 txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r
199 txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
200 , succ = lookup (succ fc) }
201 txnode other = mapExpDeep exp other
202
203 exp :: CmmExpr -> CmmExpr
204 exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
205 exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
206 exp e = e
207
208 mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
209 mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
210
211 ----------------------------------------------------------------
212 -- Build a map from a block to its set of predecessors. Very useful.
213
214 predMap :: [CmmBlock] -> BlockEnv BlockSet
215 predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
216 where add_preds block env = foldl (add (entryLabel block)) env (successors block)
217 add bid env b' =
218 mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
219
220
221 -----------------------------------------------------------------------------
222 --
223 -- Removing unreachable blocks
224
225 removeUnreachableBlocks :: CmmGraph -> CmmGraph
226 removeUnreachableBlocks g
227 | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
228 | otherwise = g
229 where blocks = postorderDfs g