Typos in comments [ci skip]
[ghc.git] / compiler / cmm / CmmProcPoint.hs
1 {-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
2
3 module CmmProcPoint
4 ( ProcPointSet, Status(..)
5 , callProcPoints, minimalProcPointSet
6 , splitAtProcPoints, procPointAnalysis
7 , attachContInfoTables
8 )
9 where
10
11 import Prelude hiding (last, unzip, succ, zip)
12
13 import DynFlags
14 import BlockId
15 import CLabel
16 import Cmm
17 import PprCmm ()
18 import CmmUtils
19 import CmmInfo
20 import CmmLive
21 import CmmSwitch
22 import Data.List (sortBy)
23 import Maybes
24 import Control.Monad
25 import Outputable
26 import Platform
27 import UniqSupply
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
89 Note [Proc-point analysis]
90 ~~~~~~~~~~~~~~~~~~~~~~~~~~
91
92 Given a specified set of proc-points (a set of block-ids), "proc-point
93 analysis" figures out, for every block, which proc-point it belongs to.
94 All the blocks belonging to proc-point P will constitute a single
95 top-level C procedure.
96
97 A non-proc-point block B "belongs to" a proc-point P iff B is
98 reachable from P without going through another proc-point.
99
100 Invariant: a block B should belong to at most one proc-point; if it
101 belongs to two, that's a bug.
102
103 Note [Non-existing proc-points]
104 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
105
106 On some architectures it might happen that the list of proc-points
107 computed before stack layout pass will be invalidated by the stack
108 layout. This will happen if stack layout removes from the graph
109 blocks that were determined to be proc-points. Later on in the pipeline
110 we use list of proc-points to perform [Proc-point analysis], but
111 if a proc-point does not exist anymore then we will get compiler panic.
112 See #8205.
113 -}
114
115 type ProcPointSet = LabelSet
116
117 data Status
118 = ReachedBy ProcPointSet -- set of proc points that directly reach the block
119 | ProcPoint -- this block is itself a proc point
120
121 instance Outputable Status where
122 ppr (ReachedBy ps)
123 | setNull ps = text "<not-reached>"
124 | otherwise = text "reached by" <+>
125 (hsep $ punctuate comma $ map ppr $ setElems ps)
126 ppr ProcPoint = text "<procpt>"
127
128 --------------------------------------------------
129 -- Proc point analysis
130
131 -- Once you know what the proc-points are, figure out
132 -- what proc-points each block is reachable from
133 -- See Note [Proc-point analysis]
134 procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
135 procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
136 analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
137 where
138 initProcPoints =
139 mkFactBase
140 procPointLattice
141 [ (id, ProcPoint)
142 | id <- setElems procPoints
143 -- See Note [Non-existing proc-points]
144 , id `setMember` labelsInGraph
145 ]
146 labelsInGraph = labelsDefined graph
147
148 procPointTransfer :: TransferFun Status
149 procPointTransfer block facts =
150 let label = entryLabel block
151 !fact = case getFact procPointLattice label facts of
152 ProcPoint -> ReachedBy $! setSingleton label
153 f -> f
154 result = map (\id -> (id, fact)) (successors block)
155 in mkFactBase procPointLattice result
156
157 procPointLattice :: DataflowLattice Status
158 procPointLattice = DataflowLattice unreached add_to
159 where
160 unreached = ReachedBy setEmpty
161 add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
162 add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
163 add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
164 | setSize union > setSize p = Changed (ReachedBy union)
165 | otherwise = NotChanged (ReachedBy p)
166 where
167 union = setUnion p' p
168
169 ----------------------------------------------------------------------
170
171 -- It is worth distinguishing two sets of proc points: those that are
172 -- induced by calls in the original graph and those that are
173 -- introduced because they're reachable from multiple proc points.
174 --
175 -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
176 callProcPoints :: CmmGraph -> ProcPointSet
177 callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
178 where add :: CmmBlock -> LabelSet -> LabelSet
179 add b set = case lastNode b of
180 CmmCall {cml_cont = Just k} -> setInsert k set
181 CmmForeignCall {succ=k} -> setInsert k set
182 _ -> set
183
184 minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
185 -> UniqSM ProcPointSet
186 -- Given the set of successors of calls (which must be proc-points)
187 -- figure out the minimal set of necessary proc-points
188 minimalProcPointSet platform callProcPoints g
189 = extendPPSet platform g (postorderDfs g) callProcPoints
190
191 extendPPSet
192 :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
193 extendPPSet platform g blocks procPoints =
194 let env = procPointAnalysis procPoints g
195 add block pps = let id = entryLabel block
196 in case mapLookup id env of
197 Just ProcPoint -> setInsert id pps
198 _ -> pps
199 procPoints' = foldGraphBlocks add setEmpty g
200 newPoints = mapMaybe ppSuccessor blocks
201 newPoint = listToMaybe newPoints
202 ppSuccessor b =
203 let nreached id = case mapLookup id env `orElse`
204 pprPanic "no ppt" (ppr id <+> ppr b) of
205 ProcPoint -> 1
206 ReachedBy ps -> setSize ps
207 block_procpoints = nreached (entryLabel b)
208 -- | Looking for a successor of b that is reached by
209 -- more proc points than b and is not already a proc
210 -- point. If found, it can become a proc point.
211 newId succ_id = not (setMember succ_id procPoints') &&
212 nreached succ_id > block_procpoints
213 in listToMaybe $ filter newId $ successors b
214
215 in case newPoint of
216 Just id ->
217 if setMember id procPoints'
218 then panic "added old proc pt"
219 else extendPPSet platform g blocks (setInsert id procPoints')
220 Nothing -> return procPoints'
221
222
223 -- At this point, we have found a set of procpoints, each of which should be
224 -- the entry point of a procedure.
225 -- Now, we create the procedure for each proc point,
226 -- which requires that we:
227 -- 1. build a map from proc points to the blocks reachable from the proc point
228 -- 2. turn each branch to a proc point into a jump
229 -- 3. turn calls and returns into jumps
230 -- 4. build info tables for the procedures -- and update the info table for
231 -- the SRTs in the entry procedure as well.
232 -- Input invariant: A block should only be reachable from a single ProcPoint.
233 -- ToDo: use the _ret naming convention that the old code generator
234 -- used. -- EZY
235 splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
236 CmmDecl -> UniqSM [CmmDecl]
237 splitAtProcPoints dflags entry_label callPPs procPoints procMap
238 (CmmProc (TopInfo {info_tbls = info_tbls})
239 top_l _ g@(CmmGraph {g_entry=entry})) =
240 do -- Build a map from procpoints to the blocks they reach
241 let addBlock
242 :: CmmBlock
243 -> LabelMap (LabelMap CmmBlock)
244 -> LabelMap (LabelMap CmmBlock)
245 addBlock b graphEnv =
246 case mapLookup bid procMap of
247 Just ProcPoint -> add graphEnv bid bid b
248 Just (ReachedBy set) ->
249 case setElems set of
250 [] -> graphEnv
251 [id] -> add graphEnv id bid b
252 _ -> panic "Each block should be reachable from only one ProcPoint"
253 Nothing -> graphEnv
254 where bid = entryLabel b
255 add graphEnv procId bid b = mapInsert procId graph' graphEnv
256 where graph = mapLookup procId graphEnv `orElse` mapEmpty
257 graph' = mapInsert bid b graph
258
259 let liveness = cmmGlobalLiveness dflags g
260 let ppLiveness pp = filter isArgReg $
261 regSetToList $
262 expectJust "ppLiveness" $ mapLookup pp liveness
263
264 graphEnv <- return $ foldGraphBlocks addBlock mapEmpty g
265
266 -- Build a map from proc point BlockId to pairs of:
267 -- * Labels for their new procedures
268 -- * Labels for the info tables of their new procedures (only if
269 -- the proc point is a callPP)
270 -- Due to common blockification, we may overestimate the set of procpoints.
271 let add_label map pp = mapInsert pp lbls map
272 where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
273 | otherwise = (block_lbl, guard (setMember pp callPPs) >>
274 Just (toInfoLbl block_lbl))
275 where block_lbl = blockLbl pp
276
277 procLabels :: LabelMap (CLabel, Maybe CLabel)
278 procLabels = foldl add_label mapEmpty
279 (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
280
281 -- In each new graph, add blocks jumping off to the new procedures,
282 -- and replace branches to procpoints with branches to the jump-off blocks
283 let add_jump_block
284 :: (LabelMap Label, [CmmBlock])
285 -> (Label, CLabel)
286 -> UniqSM (LabelMap Label, [CmmBlock])
287 add_jump_block (env, bs) (pp, l) =
288 do bid <- liftM mkBlockId getUniqueM
289 let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
290 live = ppLiveness pp
291 jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
292 return (mapInsert pp bid env, b : bs)
293
294 add_jumps
295 :: LabelMap CmmGraph
296 -> (Label, LabelMap CmmBlock)
297 -> UniqSM (LabelMap CmmGraph)
298 add_jumps newGraphEnv (ppId, blockEnv) =
299 do let needed_jumps = -- find which procpoints we currently branch to
300 mapFold add_if_branch_to_pp [] blockEnv
301 add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
302 add_if_branch_to_pp block rst =
303 case lastNode block of
304 CmmBranch id -> add_if_pp id rst
305 CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)
306 CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids
307 _ -> rst
308
309 -- when jumping to a PP that has an info table, if
310 -- tablesNextToCode is off we must jump to the entry
311 -- label instead.
312 jump_label (Just info_lbl) _
313 | tablesNextToCode dflags = info_lbl
314 | otherwise = toEntryLbl info_lbl
315 jump_label Nothing block_lbl = block_lbl
316
317 add_if_pp id rst = case mapLookup id procLabels of
318 Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
319 Nothing -> rst
320 (jumpEnv, jumpBlocks) <-
321 foldM add_jump_block (mapEmpty, []) needed_jumps
322 -- update the entry block
323 let b = expectJust "block in env" $ mapLookup ppId blockEnv
324 blockEnv' = mapInsert ppId b blockEnv
325 -- replace branches to procpoints with branches to jumps
326 blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
327 -- add the jump blocks to the graph
328 blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
329 let g' = ofBlockMap ppId blockEnv'''
330 -- pprTrace "g' pre jumps" (ppr g') $ do
331 return (mapInsert ppId g' newGraphEnv)
332
333 graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
334
335 let to_proc (bid, g)
336 | bid == entry
337 = CmmProc (TopInfo {info_tbls = info_tbls,
338 stack_info = stack_info})
339 top_l live g'
340 | otherwise
341 = case expectJust "pp label" $ mapLookup bid procLabels of
342 (lbl, Just info_lbl)
343 -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
344 , stack_info=stack_info})
345 lbl live g'
346 (lbl, Nothing)
347 -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
348 lbl live g'
349 where
350 g' = replacePPIds g
351 live = ppLiveness (g_entry g')
352 stack_info = StackInfo { arg_space = 0
353 , updfr_space = Nothing
354 , do_layout = True }
355 -- cannot use panic, this is printed by -ddump-cmm
356
357 -- References to procpoint IDs can now be replaced with the
358 -- infotable's label
359 replacePPIds g = {-# SCC "replacePPIds" #-}
360 mapGraphNodes (id, mapExp repl, mapExp repl) g
361 where repl e@(CmmLit (CmmBlock bid)) =
362 case mapLookup bid procLabels of
363 Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
364 _ -> e
365 repl e = e
366
367 -- The C back end expects to see return continuations before the
368 -- call sites. Here, we sort them in reverse order -- it gets
369 -- reversed later.
370 let (_, block_order) =
371 foldl add_block_num (0::Int, mapEmpty :: LabelMap Int)
372 (postorderDfs g)
373 add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
374 sort_fn (bid, _) (bid', _) =
375 compare (expectJust "block_order" $ mapLookup bid block_order)
376 (expectJust "block_order" $ mapLookup bid' block_order)
377 procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
378 return -- pprTrace "procLabels" (ppr procLabels)
379 -- pprTrace "splitting graphs" (ppr procs)
380 procs
381 splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
382
383 -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
384 -- recursive lookup, see comment below.
385 replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
386 replaceBranches env cmmg
387 = {-# SCC "replaceBranches" #-}
388 ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
389 where
390 f block = replaceLastNode block $ last (lastNode block)
391
392 last :: CmmNode O C -> CmmNode O C
393 last (CmmBranch id) = CmmBranch (lookup id)
394 last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l
395 last (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets lookup ids)
396 last l@(CmmCall {}) = l { cml_cont = Nothing }
397 -- NB. remove the continuation of a CmmCall, since this
398 -- label will now be in a different CmmProc. Not only
399 -- is this tidier, it stops CmmLint from complaining.
400 last l@(CmmForeignCall {}) = l
401 lookup id = fmap lookup (mapLookup id env) `orElse` id
402 -- XXX: this is a recursive lookup, it follows chains
403 -- until the lookup returns Nothing, at which point we
404 -- return the last BlockId
405
406 -- --------------------------------------------------------------
407 -- Not splitting proc points: add info tables for continuations
408
409 attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
410 attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
411 = CmmProc top_info{info_tbls = info_tbls'} top_l live g
412 where
413 info_tbls' = mapUnion (info_tbls top_info) $
414 mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
415 | l <- setElems call_proc_points
416 , l /= g_entry g ]
417 attachContInfoTables _ other_decl
418 = other_decl
419
420 ----------------------------------------------------------------
421
422 {-
423 Note [Direct reachability]
424
425 Block B is directly reachable from proc point P iff control can flow
426 from P to B without passing through an intervening proc point.
427 -}
428
429 ----------------------------------------------------------------
430
431 {-
432 Note [No simple dataflow]
433
434 Sadly, it seems impossible to compute the proc points using a single
435 dataflow pass. One might attempt to use this simple lattice:
436
437 data Location = Unknown
438 | InProc BlockId -- node is in procedure headed by the named proc point
439 | ProcPoint -- node is itself a proc point
440
441 At a join, a node in two different blocks becomes a proc point.
442 The difficulty is that the change of information during iterative
443 computation may promote a node prematurely. Here's a program that
444 illustrates the difficulty:
445
446 f () {
447 entry:
448 ....
449 L1:
450 if (...) { ... }
451 else { ... }
452
453 L2: if (...) { g(); goto L1; }
454 return x + y;
455 }
456
457 The only proc-point needed (besides the entry) is L1. But in an
458 iterative analysis, consider what happens to L2. On the first pass
459 through, it rises from Unknown to 'InProc entry', but when L1 is
460 promoted to a proc point (because it's the successor of g()), L1's
461 successors will be promoted to 'InProc L1'. The problem hits when the
462 new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
463 The join operation makes it a proc point when in fact it needn't be,
464 because its immediate dominator L1 is already a proc point and there
465 are no other proc points that directly reach L2.
466 -}
467
468
469
470 {- Note [Separate Adams optimization]
471 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
472 It may be worthwhile to attempt the Adams optimization by rewriting
473 the graph before the assignment of proc-point protocols. Here are a
474 couple of rules:
475
476 g() returns to k; g() returns to L;
477 k: CopyIn c ress; goto L:
478 ... ==> ...
479 L: // no CopyIn node here L: CopyIn c ress;
480
481
482 And when c == c' and ress == ress', this also:
483
484 g() returns to k; g() returns to L;
485 k: CopyIn c ress; goto L:
486 ... ==> ...
487 L: CopyIn c' ress' L: CopyIn c' ress' ;
488
489 In both cases the goal is to eliminate k.
490 -}