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