disable a debug trace
[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 ( runCmmContFlowOpts
6 , removeUnreachableBlocks, replaceBranches
7 )
8 where
9
10 import BlockId
11 import Cmm
12 import CmmUtils
13 import Digraph
14 import Maybes
15 import Outputable
16
17 import Compiler.Hoopl
18 import Control.Monad
19 import Prelude hiding (succ, unzip, zip)
20
21 -----------------------------------------------------------------------------
22 --
23 -- Control-flow optimisations
24 --
25 -----------------------------------------------------------------------------
26
27 runCmmContFlowOpts :: CmmGroup -> CmmGroup
28 runCmmContFlowOpts = map (optProc cmmCfgOpts)
29
30 cmmCfgOpts :: CmmGraph -> CmmGraph
31 cmmCfgOpts = removeUnreachableBlocks . blockConcat . branchChainElim
32 -- Here branchChainElim can ultimately be replaced
33 -- with a more exciting combination of optimisations
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 -- Branch Chain Elimination
42 --
43 -----------------------------------------------------------------------------
44
45 -- | Remove any basic block of the form L: goto L', and replace L with
46 -- L' everywhere else, unless L is the successor of a call instruction
47 -- and L' is the entry block. You don't want to set the successor of a
48 -- function call to the entry block because there is no good way to
49 -- store both the infotables for the call and from the callee, while
50 -- putting the stack pointer in a consistent place.
51 --
52 -- JD isn't quite sure when it's safe to share continuations for different
53 -- function calls -- have to think about where the SP will be,
54 -- so we'll table that problem for now by leaving all call successors alone.
55
56 branchChainElim :: CmmGraph -> CmmGraph
57 branchChainElim g
58 | null lone_branch_blocks = g -- No blocks to remove
59 | otherwise = {- pprTrace "branchChainElim" (ppr forest) $ -}
60 replaceLabels (mapFromList edges) g
61 where
62 blocks = toBlockList g
63
64 lone_branch_blocks :: [(BlockId, BlockId)]
65 -- each (L,K) is a block of the form
66 -- L : goto K
67 lone_branch_blocks = mapCatMaybes isLoneBranch blocks
68
69 call_succs = foldl add emptyBlockSet blocks
70 where add :: BlockSet -> CmmBlock -> BlockSet
71 add succs b =
72 case lastNode b of
73 (CmmCall _ (Just k) _ _ _) -> setInsert k succs
74 (CmmForeignCall {succ=k}) -> setInsert k succs
75 _ -> succs
76
77 isLoneBranch :: CmmBlock -> Maybe (BlockId, BlockId)
78 isLoneBranch block
79 | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block
80 , not (setMember id call_succs)
81 = Just (id,target)
82 | otherwise
83 = Nothing
84
85 -- We build a graph from lone_branch_blocks (every node has only
86 -- one out edge). Then we
87 -- - topologically sort the graph: if from A we can reach B,
88 -- then A occurs before B in the result list.
89 -- - depth-first search starting from the nodes in this list.
90 -- This gives us a [[node]], in which each list is a dependency
91 -- chain.
92 -- - for each list [a1,a2,...an] replace branches to ai with an.
93 --
94 -- This approach nicely deals with cycles by ignoring them.
95 -- Branches in a cycle will be redirected to somewhere in the
96 -- cycle, but we don't really care where. A cycle should be dead code,
97 -- and so will be eliminated by removeUnreachableBlocks.
98 --
99 fromNode (b,_) = b
100 toNode a = (a,a)
101
102 all_block_ids :: LabelSet
103 all_block_ids = setFromList (map fst lone_branch_blocks)
104 `setUnion`
105 setFromList (map snd lone_branch_blocks)
106
107 forest = dfsTopSortG $ graphFromVerticesAndAdjacency nodes lone_branch_blocks
108 where nodes = map toNode $ setElems $ all_block_ids
109
110 edges = [ (fromNode y, fromNode x)
111 | (x:xs) <- map reverse forest, y <- xs ]
112
113 ----------------------------------------------------------------
114
115 replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
116 replaceLabels env =
117 replace_eid . mapGraphNodes1 txnode
118 where
119 replace_eid g = g {g_entry = lookup (g_entry g)}
120 lookup id = mapLookup id env `orElse` id
121
122 txnode :: CmmNode e x -> CmmNode e x
123 txnode (CmmBranch bid) = CmmBranch (lookup bid)
124 txnode (CmmCondBranch p t f) = CmmCondBranch (exp p) (lookup t) (lookup f)
125 txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms)
126 txnode (CmmCall t k a res r) = CmmCall (exp t) (liftM lookup k) a res r
127 txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
128 , succ = lookup (succ fc) }
129 txnode other = mapExpDeep exp other
130
131 exp :: CmmExpr -> CmmExpr
132 exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
133 exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
134 exp e = e
135
136
137 replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
138 replaceBranches env g = mapGraphNodes (id, id, last) g
139 where
140 last :: CmmNode O C -> CmmNode O C
141 last (CmmBranch id) = CmmBranch (lookup id)
142 last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
143 last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
144 last l@(CmmCall {}) = l
145 last l@(CmmForeignCall {}) = l
146 lookup id = fmap lookup (mapLookup id env) `orElse` id
147 -- XXX: this is a recursive lookup, it follows chains until the lookup
148 -- returns Nothing, at which point we return the last BlockId
149
150 ----------------------------------------------------------------
151 -- Build a map from a block to its set of predecessors. Very useful.
152 predMap :: [CmmBlock] -> BlockEnv BlockSet
153 predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
154 where add_preds block env = foldl (add (entryLabel block)) env (successors block)
155 add bid env b' =
156 mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
157
158 -----------------------------------------------------------------------------
159 --
160 -- Block concatenation
161 --
162 -----------------------------------------------------------------------------
163
164 -- If a block B branches to a label L, L is not the entry block,
165 -- and L has no other predecessors,
166 -- then we can splice the block starting with L onto the end of B.
167 -- Order matters, so we work bottom up (reverse postorder DFS).
168 -- This optimization can be inhibited by unreachable blocks, but
169 -- the reverse postorder DFS returns only reachable blocks.
170 --
171 -- To ensure correctness, we have to make sure that the BlockId of the block
172 -- we are about to eliminate is not named in another instruction.
173 --
174 -- Note: This optimization does _not_ subsume branch chain elimination.
175
176 blockConcat :: CmmGraph -> CmmGraph
177 blockConcat g@(CmmGraph {g_entry=eid}) =
178 replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
179 where
180 blocks = postorderDfs g
181
182 (blocks', concatMap) =
183 foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
184
185 maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
186 maybe_concat b unchanged@(blocks', concatMap) =
187 let bid = entryLabel b
188 in case blockToNodeList b of
189 (JustC h, m, JustC (CmmBranch b')) ->
190 if canConcatWith b' then
191 (mapInsert bid (splice blocks' h m b') blocks',
192 mapInsert b' bid concatMap)
193 else unchanged
194 _ -> unchanged
195
196 num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0
197
198 canConcatWith b' = b' /= eid && num_preds b' == 1
199
200 backEdges = predMap blocks
201
202 splice :: forall map n e x.
203 IsMap map =>
204 map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
205 splice blocks' h m bid' =
206 case mapLookup bid' blocks' of
207 Nothing -> panic "unknown successor block"
208 Just block | (_, m', l') <- blockToNodeList block
209 -> blockOfNodeList (JustC h, (m ++ m'), l')
210
211
212 -----------------------------------------------------------------------------
213 --
214 -- Removing unreachable blocks
215 --
216 -----------------------------------------------------------------------------
217
218 removeUnreachableBlocks :: CmmGraph -> CmmGraph
219 removeUnreachableBlocks g
220 | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
221 | otherwise = g
222 where blocks = postorderDfs g