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