Improve panic printout
[ghc.git] / compiler / cmm / CmmProcPoint.hs
1 {-# LANGUAGE GADTs, DisambiguateRecordFields #-}
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 (cmmGlobalLiveness)
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
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 procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status)
132 -- Once you know what the proc-points are, figure out
133 -- what proc-points each block is reachable from
134 -- See Note [Proc-point analysis]
135 procPointAnalysis procPoints g@(CmmGraph {g_graph = graph}) =
136 -- pprTrace "procPointAnalysis" (ppr procPoints) $
137 dataflowAnalFwdBlocks g initProcPoints $ analFwd lattice forward
138 where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints,
139 id `setMember` labelsInGraph ]
140 -- See Note [Non-existing proc-points]
141 labelsInGraph = labelsDefined graph
142 -- transfer equations
143
144 forward :: FwdTransfer CmmNode Status
145 forward = mkFTransfer3 first middle last
146 where
147 first :: CmmNode C O -> Status -> Status
148 first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
149 first _ x = x
150
151 middle _ x = x
152
153 last :: CmmNode O C -> Status -> FactBase Status
154 last l x = mkFactBase lattice $ map (\id -> (id, x)) (successors l)
155
156 lattice :: DataflowLattice Status
157 lattice = DataflowLattice "direct proc-point reachability" unreached add_to
158 where unreached = ReachedBy setEmpty
159 add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint)
160 add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint)
161 -- because of previous case
162 add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
163 | setSize union > setSize p = (SomeChange, ReachedBy union)
164 | otherwise = (NoChange, ReachedBy p)
165 where
166 union = setUnion p' p
167
168 ----------------------------------------------------------------------
169
170 -- It is worth distinguishing two sets of proc points: those that are
171 -- induced by calls in the original graph and those that are
172 -- introduced because they're reachable from multiple proc points.
173 --
174 -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
175 callProcPoints :: CmmGraph -> ProcPointSet
176 callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
177 where add :: CmmBlock -> BlockSet -> BlockSet
178 add b set = case lastNode b of
179 CmmCall {cml_cont = Just k} -> setInsert k set
180 CmmForeignCall {succ=k} -> setInsert k set
181 _ -> set
182
183 minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
184 -> UniqSM ProcPointSet
185 -- Given the set of successors of calls (which must be proc-points)
186 -- figure out the minimal set of necessary proc-points
187 minimalProcPointSet platform callProcPoints g
188 = extendPPSet platform g (postorderDfs g) callProcPoints
189
190 extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
191 extendPPSet platform g blocks procPoints =
192 do env <- procPointAnalysis procPoints g
193 -- pprTrace "extensPPSet" (ppr env) $ return ()
194 let add block pps = let id = entryLabel block
195 in case mapLookup id env of
196 Just ProcPoint -> setInsert id pps
197 _ -> pps
198 procPoints' = foldGraphBlocks add setEmpty g
199 newPoints = mapMaybe ppSuccessor blocks
200 newPoint = listToMaybe newPoints
201 ppSuccessor b =
202 let nreached id = case mapLookup id env `orElse`
203 pprPanic "no ppt" (ppr id <+> ppr b) of
204 ProcPoint -> 1
205 ReachedBy ps -> setSize ps
206 block_procpoints = nreached (entryLabel b)
207 -- | Looking for a successor of b that is reached by
208 -- more proc points than b and is not already a proc
209 -- point. If found, it can become a proc point.
210 newId succ_id = not (setMember succ_id procPoints') &&
211 nreached succ_id > block_procpoints
212 in listToMaybe $ filter newId $ successors b
213 {-
214 case newPoints of
215 [] -> return procPoints'
216 pps -> extendPPSet g blocks
217 (foldl extendBlockSet procPoints' pps)
218 -}
219 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 -> BlockEnv 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 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 emptyBlockMap 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 (env, bs) (pp, l) =
284 do bid <- liftM mkBlockId getUniqueM
285 let b = blockJoin (CmmEntry bid) emptyBlock jump
286 live = ppLiveness pp
287 jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
288 return (mapInsert pp bid env, b : bs)
289
290 add_jumps newGraphEnv (ppId, blockEnv) =
291 do let needed_jumps = -- find which procpoints we currently branch to
292 mapFold add_if_branch_to_pp [] blockEnv
293 add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
294 add_if_branch_to_pp block rst =
295 case lastNode block of
296 CmmBranch id -> add_if_pp id rst
297 CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
298 CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl)
299 _ -> rst
300
301 -- when jumping to a PP that has an info table, if
302 -- tablesNextToCode is off we must jump to the entry
303 -- label instead.
304 jump_label (Just info_lbl) _
305 | tablesNextToCode dflags = info_lbl
306 | otherwise = toEntryLbl info_lbl
307 jump_label Nothing block_lbl = block_lbl
308
309 add_if_pp id rst = case mapLookup id procLabels of
310 Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
311 Nothing -> rst
312 (jumpEnv, jumpBlocks) <-
313 foldM add_jump_block (mapEmpty, []) needed_jumps
314 -- update the entry block
315 let b = expectJust "block in env" $ mapLookup ppId blockEnv
316 blockEnv' = mapInsert ppId b blockEnv
317 -- replace branches to procpoints with branches to jumps
318 blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
319 -- add the jump blocks to the graph
320 blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
321 let g' = ofBlockMap ppId blockEnv'''
322 -- pprTrace "g' pre jumps" (ppr g') $ do
323 return (mapInsert ppId g' newGraphEnv)
324
325 graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
326
327 let to_proc (bid, g)
328 | bid == entry
329 = CmmProc (TopInfo {info_tbls = info_tbls,
330 stack_info = stack_info})
331 top_l live g'
332 | otherwise
333 = case expectJust "pp label" $ mapLookup bid procLabels of
334 (lbl, Just info_lbl)
335 -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
336 , stack_info=stack_info})
337 lbl live g'
338 (lbl, Nothing)
339 -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
340 lbl live g'
341 where
342 g' = replacePPIds g
343 live = ppLiveness (g_entry g')
344 stack_info = StackInfo { arg_space = 0
345 , updfr_space = Nothing
346 , do_layout = True }
347 -- cannot use panic, this is printed by -ddump-cmm
348
349 -- References to procpoint IDs can now be replaced with the
350 -- infotable's label
351 replacePPIds g = {-# SCC "replacePPIds" #-}
352 mapGraphNodes (id, mapExp repl, mapExp repl) g
353 where repl e@(CmmLit (CmmBlock bid)) =
354 case mapLookup bid procLabels of
355 Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
356 _ -> e
357 repl e = e
358
359 -- The C back end expects to see return continuations before the
360 -- call sites. Here, we sort them in reverse order -- it gets
361 -- reversed later.
362 let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g)
363 add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
364 sort_fn (bid, _) (bid', _) =
365 compare (expectJust "block_order" $ mapLookup bid block_order)
366 (expectJust "block_order" $ mapLookup bid' block_order)
367 procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
368 return -- pprTrace "procLabels" (ppr procLabels)
369 -- pprTrace "splitting graphs" (ppr procs)
370 procs
371 splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
372
373 -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
374 -- recursive lookup, see comment below.
375 replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
376 replaceBranches env cmmg
377 = {-# SCC "replaceBranches" #-}
378 ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
379 where
380 f block = replaceLastNode block $ last (lastNode block)
381
382 last :: CmmNode O C -> CmmNode O C
383 last (CmmBranch id) = CmmBranch (lookup id)
384 last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
385 last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
386 last l@(CmmCall {}) = l { cml_cont = Nothing }
387 -- NB. remove the continuation of a CmmCall, since this
388 -- label will now be in a different CmmProc. Not only
389 -- is this tidier, it stops CmmLint from complaining.
390 last l@(CmmForeignCall {}) = l
391 lookup id = fmap lookup (mapLookup id env) `orElse` id
392 -- XXX: this is a recursive lookup, it follows chains
393 -- until the lookup returns Nothing, at which point we
394 -- return the last BlockId
395
396 -- --------------------------------------------------------------
397 -- Not splitting proc points: add info tables for continuations
398
399 attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
400 attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
401 = CmmProc top_info{info_tbls = info_tbls'} top_l live g
402 where
403 info_tbls' = mapUnion (info_tbls top_info) $
404 mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
405 | l <- setElems call_proc_points
406 , l /= g_entry g ]
407 attachContInfoTables _ other_decl
408 = other_decl
409
410 ----------------------------------------------------------------
411
412 {-
413 Note [Direct reachability]
414
415 Block B is directly reachable from proc point P iff control can flow
416 from P to B without passing through an intervening proc point.
417 -}
418
419 ----------------------------------------------------------------
420
421 {-
422 Note [No simple dataflow]
423
424 Sadly, it seems impossible to compute the proc points using a single
425 dataflow pass. One might attempt to use this simple lattice:
426
427 data Location = Unknown
428 | InProc BlockId -- node is in procedure headed by the named proc point
429 | ProcPoint -- node is itself a proc point
430
431 At a join, a node in two different blocks becomes a proc point.
432 The difficulty is that the change of information during iterative
433 computation may promote a node prematurely. Here's a program that
434 illustrates the difficulty:
435
436 f () {
437 entry:
438 ....
439 L1:
440 if (...) { ... }
441 else { ... }
442
443 L2: if (...) { g(); goto L1; }
444 return x + y;
445 }
446
447 The only proc-point needed (besides the entry) is L1. But in an
448 iterative analysis, consider what happens to L2. On the first pass
449 through, it rises from Unknown to 'InProc entry', but when L1 is
450 promoted to a proc point (because it's the successor of g()), L1's
451 successors will be promoted to 'InProc L1'. The problem hits when the
452 new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
453 The join operation makes it a proc point when in fact it needn't be,
454 because its immediate dominator L1 is already a proc point and there
455 are no other proc points that directly reach L2.
456 -}
457
458
459
460 {- Note [Separate Adams optimization]
461 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
462 It may be worthwhile to attempt the Adams optimization by rewriting
463 the graph before the assignment of proc-point protocols. Here are a
464 couple of rules:
465
466 g() returns to k; g() returns to L;
467 k: CopyIn c ress; goto L:
468 ... ==> ...
469 L: // no CopyIn node here L: CopyIn c ress;
470
471
472 And when c == c' and ress == ress', this also:
473
474 g() returns to k; g() returns to L;
475 k: CopyIn c ress; goto L:
476 ... ==> ...
477 L: CopyIn c' ress' L: CopyIn c' ress' ;
478
479 In both cases the goal is to eliminate k.
480 -}