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