Produce new-style Cmm from the Cmm parser
[ghc.git] / compiler / cmm / CmmProcPoint.hs
1 {-# LANGUAGE GADTs, DisambiguateRecordFields #-}
2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
3
4 module CmmProcPoint
5 ( ProcPointSet, Status(..)
6 , callProcPoints, minimalProcPointSet
7 , splitAtProcPoints, procPointAnalysis
8 , attachContInfoTables
9 )
10 where
11
12 import Prelude hiding (last, unzip, succ, zip)
13
14 import DynFlags
15 import BlockId
16 import CLabel
17 import Cmm
18 import PprCmm ()
19 import CmmUtils
20 import CmmInfo
21 import Data.List (sortBy)
22 import Maybes
23 import Control.Monad
24 import Outputable
25 import Platform
26 import UniqSupply
27
28 import Hoopl
29
30 -- Compute a minimal set of proc points for a control-flow graph.
31
32 -- Determine a protocol for each proc point (which live variables will
33 -- be passed as arguments and which will be on the stack).
34
35 {-
36 A proc point is a basic block that, after CPS transformation, will
37 start a new function. The entry block of the original function is a
38 proc point, as is the continuation of each function call.
39 A third kind of proc point arises if we want to avoid copying code.
40 Suppose we have code like the following:
41
42 f() {
43 if (...) { ..1..; call foo(); ..2..}
44 else { ..3..; call bar(); ..4..}
45 x = y + z;
46 return x;
47 }
48
49 The statement 'x = y + z' can be reached from two different proc
50 points: the continuations of foo() and bar(). We would prefer not to
51 put a copy in each continuation; instead we would like 'x = y + z' to
52 be the start of a new procedure to which the continuations can jump:
53
54 f_cps () {
55 if (...) { ..1..; push k_foo; jump foo_cps(); }
56 else { ..3..; push k_bar; jump bar_cps(); }
57 }
58 k_foo() { ..2..; jump k_join(y, z); }
59 k_bar() { ..4..; jump k_join(y, z); }
60 k_join(y, z) { x = y + z; return x; }
61
62 You might think then that a criterion to make a node a proc point is
63 that it is directly reached by two distinct proc points. (Note
64 [Direct reachability].) But this criterion is a bit too simple; for
65 example, 'return x' is also reached by two proc points, yet there is
66 no point in pulling it out of k_join. A good criterion would be to
67 say that a node should be made a proc point if it is reached by a set
68 of proc points that is different than its immediate dominator. NR
69 believes this criterion can be shown to produce a minimum set of proc
70 points, and given a dominator tree, the proc points can be chosen in
71 time linear in the number of blocks. Lacking a dominator analysis,
72 however, we turn instead to an iterative solution, starting with no
73 proc points and adding them according to these rules:
74
75 1. The entry block is a proc point.
76 2. The continuation of a call is a proc point.
77 3. A node is a proc point if it is directly reached by more proc
78 points than one of its predecessors.
79
80 Because we don't understand the problem very well, we apply rule 3 at
81 most once per iteration, then recompute the reachability information.
82 (See Note [No simple dataflow].) The choice of the new proc point is
83 arbitrary, and I don't know if the choice affects the final solution,
84 so I don't know if the number of proc points chosen is the
85 minimum---but the set will be minimal.
86 -}
87
88 type ProcPointSet = BlockSet
89
90 data Status
91 = ReachedBy ProcPointSet -- set of proc points that directly reach the block
92 | ProcPoint -- this block is itself a proc point
93
94 instance Outputable Status where
95 ppr (ReachedBy ps)
96 | setNull ps = text "<not-reached>"
97 | otherwise = text "reached by" <+>
98 (hsep $ punctuate comma $ map ppr $ setElems ps)
99 ppr ProcPoint = text "<procpt>"
100
101 --------------------------------------------------
102 -- Proc point analysis
103
104 procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status)
105 -- Once you know what the proc-points are, figure out
106 -- what proc-points each block is reachable from
107 procPointAnalysis procPoints g =
108 -- pprTrace "procPointAnalysis" (ppr procPoints) $
109 dataflowAnalFwdBlocks g initProcPoints $ analFwd lattice forward
110 where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
111
112 -- transfer equations
113
114 forward :: FwdTransfer CmmNode Status
115 forward = mkFTransfer3 first middle last
116 where
117 first :: CmmNode C O -> Status -> Status
118 first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
119 first _ x = x
120
121 middle _ x = x
122
123 last :: CmmNode O C -> Status -> FactBase Status
124 last l x = mkFactBase lattice $ map (\id -> (id, x)) (successors l)
125
126 lattice :: DataflowLattice Status
127 lattice = DataflowLattice "direct proc-point reachability" unreached add_to
128 where unreached = ReachedBy setEmpty
129 add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint)
130 add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint)
131 -- because of previous case
132 add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
133 | setSize union > setSize p = (SomeChange, ReachedBy union)
134 | otherwise = (NoChange, ReachedBy p)
135 where
136 union = setUnion p' p
137
138 ----------------------------------------------------------------------
139
140 -- It is worth distinguishing two sets of proc points: those that are
141 -- induced by calls in the original graph and those that are
142 -- introduced because they're reachable from multiple proc points.
143 --
144 -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
145 callProcPoints :: CmmGraph -> ProcPointSet
146 callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
147 where add :: CmmBlock -> BlockSet -> BlockSet
148 add b set = case lastNode b of
149 CmmCall {cml_cont = Just k} -> setInsert k set
150 CmmForeignCall {succ=k} -> setInsert k set
151 _ -> set
152
153 minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
154 -> UniqSM ProcPointSet
155 -- Given the set of successors of calls (which must be proc-points)
156 -- figure out the minimal set of necessary proc-points
157 minimalProcPointSet platform callProcPoints g
158 = extendPPSet platform g (postorderDfs g) callProcPoints
159
160 extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
161 extendPPSet platform g blocks procPoints =
162 do env <- procPointAnalysis procPoints g
163 -- pprTrace "extensPPSet" (ppr env) $ return ()
164 let add block pps = let id = entryLabel block
165 in case mapLookup id env of
166 Just ProcPoint -> setInsert id pps
167 _ -> pps
168 procPoints' = foldGraphBlocks add setEmpty g
169 newPoints = mapMaybe ppSuccessor blocks
170 newPoint = listToMaybe newPoints
171 ppSuccessor b =
172 let nreached id = case mapLookup id env `orElse`
173 pprPanic "no ppt" (ppr id <+> ppr b) of
174 ProcPoint -> 1
175 ReachedBy ps -> setSize ps
176 block_procpoints = nreached (entryLabel b)
177 -- | Looking for a successor of b that is reached by
178 -- more proc points than b and is not already a proc
179 -- point. If found, it can become a proc point.
180 newId succ_id = not (setMember succ_id procPoints') &&
181 nreached succ_id > block_procpoints
182 in listToMaybe $ filter newId $ successors b
183 {-
184 case newPoints of
185 [] -> return procPoints'
186 pps -> extendPPSet g blocks
187 (foldl extendBlockSet procPoints' pps)
188 -}
189 case newPoint of
190 Just id ->
191 if setMember id procPoints'
192 then panic "added old proc pt"
193 else extendPPSet platform g blocks (setInsert id procPoints')
194 Nothing -> return procPoints'
195
196
197 -- At this point, we have found a set of procpoints, each of which should be
198 -- the entry point of a procedure.
199 -- Now, we create the procedure for each proc point,
200 -- which requires that we:
201 -- 1. build a map from proc points to the blocks reachable from the proc point
202 -- 2. turn each branch to a proc point into a jump
203 -- 3. turn calls and returns into jumps
204 -- 4. build info tables for the procedures -- and update the info table for
205 -- the SRTs in the entry procedure as well.
206 -- Input invariant: A block should only be reachable from a single ProcPoint.
207 -- ToDo: use the _ret naming convention that the old code generator
208 -- used. -- EZY
209 splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
210 CmmDecl -> UniqSM [CmmDecl]
211 splitAtProcPoints dflags entry_label callPPs procPoints procMap
212 (CmmProc (TopInfo {info_tbls = info_tbls})
213 top_l g@(CmmGraph {g_entry=entry})) =
214 do -- Build a map from procpoints to the blocks they reach
215 let addBlock b graphEnv =
216 case mapLookup bid procMap of
217 Just ProcPoint -> add graphEnv bid bid b
218 Just (ReachedBy set) ->
219 case setElems set of
220 [] -> graphEnv
221 [id] -> add graphEnv id bid b
222 _ -> panic "Each block should be reachable from only one ProcPoint"
223 Nothing -> graphEnv
224 where bid = entryLabel b
225 add graphEnv procId bid b = mapInsert procId graph' graphEnv
226 where graph = mapLookup procId graphEnv `orElse` mapEmpty
227 graph' = mapInsert bid b graph
228
229 graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g
230
231 -- Build a map from proc point BlockId to pairs of:
232 -- * Labels for their new procedures
233 -- * Labels for the info tables of their new procedures (only if
234 -- the proc point is a callPP)
235 -- Due to common blockification, we may overestimate the set of procpoints.
236 let add_label map pp = mapInsert pp lbls map
237 where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
238 | otherwise = (blockLbl pp, guard (setMember pp callPPs) >>
239 Just (infoTblLbl pp))
240
241 procLabels :: LabelMap (CLabel, Maybe CLabel)
242 procLabels = foldl add_label mapEmpty
243 (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
244
245 -- In each new graph, add blocks jumping off to the new procedures,
246 -- and replace branches to procpoints with branches to the jump-off blocks
247 let add_jump_block (env, bs) (pp, l) =
248 do bid <- liftM mkBlockId getUniqueM
249 let b = blockJoin (CmmEntry bid) emptyBlock jump
250 jump = CmmCall (CmmLit (CmmLabel l)) Nothing [{-XXX-}] 0 0 0
251 -- XXX: No regs are live at the call
252 return (mapInsert pp bid env, b : bs)
253
254 add_jumps newGraphEnv (ppId, blockEnv) =
255 do let needed_jumps = -- find which procpoints we currently branch to
256 mapFold add_if_branch_to_pp [] blockEnv
257 add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
258 add_if_branch_to_pp block rst =
259 case lastNode block of
260 CmmBranch id -> add_if_pp id rst
261 CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
262 CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl)
263 _ -> rst
264
265 -- when jumping to a PP that has an info table, if
266 -- tablesNextToCode is off we must jump to the entry
267 -- label instead.
268 jump_label (Just info_lbl) _
269 | tablesNextToCode dflags = info_lbl
270 | otherwise = toEntryLbl info_lbl
271 jump_label Nothing block_lbl = block_lbl
272
273 add_if_pp id rst = case mapLookup id procLabels of
274 Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
275 Nothing -> rst
276 (jumpEnv, jumpBlocks) <-
277 foldM add_jump_block (mapEmpty, []) needed_jumps
278 -- update the entry block
279 let b = expectJust "block in env" $ mapLookup ppId blockEnv
280 blockEnv' = mapInsert ppId b blockEnv
281 -- replace branches to procpoints with branches to jumps
282 blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
283 -- add the jump blocks to the graph
284 blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
285 let g' = ofBlockMap ppId blockEnv'''
286 -- pprTrace "g' pre jumps" (ppr g') $ do
287 return (mapInsert ppId g' newGraphEnv)
288
289 graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
290
291 let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of
292 (lbl, Just info_lbl)
293 | bid == entry
294 -> CmmProc (TopInfo {info_tbls = info_tbls,
295 stack_info = stack_info})
296 top_l (replacePPIds g)
297 | otherwise
298 -> CmmProc (TopInfo {info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl), stack_info=stack_info})
299 lbl (replacePPIds g)
300 (lbl, Nothing)
301 -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
302 lbl (replacePPIds g)
303 where
304 stack_info = StackInfo { arg_space = 0
305 , updfr_space = Nothing
306 , do_layout = True }
307 -- cannot use panic, this is printed by -ddump-cmmz
308
309 -- References to procpoint IDs can now be replaced with the
310 -- infotable's label
311 replacePPIds g = {-# SCC "replacePPIds" #-}
312 mapGraphNodes (id, mapExp repl, mapExp repl) g
313 where repl e@(CmmLit (CmmBlock bid)) =
314 case mapLookup bid procLabels of
315 Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
316 _ -> e
317 repl e = e
318
319 -- The C back end expects to see return continuations before the
320 -- call sites. Here, we sort them in reverse order -- it gets
321 -- reversed later.
322 let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g)
323 add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
324 sort_fn (bid, _) (bid', _) =
325 compare (expectJust "block_order" $ mapLookup bid block_order)
326 (expectJust "block_order" $ mapLookup bid' block_order)
327 procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
328 return -- pprTrace "procLabels" (ppr procLabels)
329 -- pprTrace "splitting graphs" (ppr procs)
330 procs
331 splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
332
333
334 -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
335 -- recursive lookup, see comment below.
336 replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
337 replaceBranches env cmmg
338 = {-# SCC "replaceBranches" #-}
339 ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
340 where
341 f block = replaceLastNode block $ last (lastNode block)
342
343 last :: CmmNode O C -> CmmNode O C
344 last (CmmBranch id) = CmmBranch (lookup id)
345 last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
346 last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
347 last l@(CmmCall {}) = l
348 last l@(CmmForeignCall {}) = l
349 lookup id = fmap lookup (mapLookup id env) `orElse` id
350 -- XXX: this is a recursive lookup, it follows chains
351 -- until the lookup returns Nothing, at which point we
352 -- return the last BlockId
353
354 -- --------------------------------------------------------------
355 -- Not splitting proc points: add info tables for continuations
356
357 attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
358 attachContInfoTables call_proc_points (CmmProc top_info top_l g)
359 = CmmProc top_info{info_tbls = info_tbls'} top_l g
360 where
361 info_tbls' = mapUnion (info_tbls top_info) $
362 mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
363 | l <- setElems call_proc_points
364 , l /= g_entry g ]
365 attachContInfoTables _ other_decl
366 = other_decl
367
368 ----------------------------------------------------------------
369
370 {-
371 Note [Direct reachability]
372
373 Block B is directly reachable from proc point P iff control can flow
374 from P to B without passing through an intervening proc point.
375 -}
376
377 ----------------------------------------------------------------
378
379 {-
380 Note [No simple dataflow]
381
382 Sadly, it seems impossible to compute the proc points using a single
383 dataflow pass. One might attempt to use this simple lattice:
384
385 data Location = Unknown
386 | InProc BlockId -- node is in procedure headed by the named proc point
387 | ProcPoint -- node is itself a proc point
388
389 At a join, a node in two different blocks becomes a proc point.
390 The difficulty is that the change of information during iterative
391 computation may promote a node prematurely. Here's a program that
392 illustrates the difficulty:
393
394 f () {
395 entry:
396 ....
397 L1:
398 if (...) { ... }
399 else { ... }
400
401 L2: if (...) { g(); goto L1; }
402 return x + y;
403 }
404
405 The only proc-point needed (besides the entry) is L1. But in an
406 iterative analysis, consider what happens to L2. On the first pass
407 through, it rises from Unknown to 'InProc entry', but when L1 is
408 promoted to a proc point (because it's the successor of g()), L1's
409 successors will be promoted to 'InProc L1'. The problem hits when the
410 new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
411 The join operation makes it a proc point when in fact it needn't be,
412 because its immediate dominator L1 is already a proc point and there
413 are no other proc points that directly reach L2.
414 -}
415
416
417
418 {- Note [Separate Adams optimization]
419 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
420 It may be worthwhile to attempt the Adams optimization by rewriting
421 the graph before the assignment of proc-point protocols. Here are a
422 couple of rules:
423
424 g() returns to k; g() returns to L;
425 k: CopyIn c ress; goto L:
426 ... ==> ...
427 L: // no CopyIn node here L: CopyIn c ress;
428
429
430 And when c == c' and ress == ress', this also:
431
432 g() returns to k; g() returns to L;
433 k: CopyIn c ress; goto L:
434 ... ==> ...
435 L: CopyIn c' ress' L: CopyIn c' ress' ;
436
437 In both cases the goal is to eliminate k.
438 -}