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