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