adding new files to do with new cmm functionality
[ghc.git] / compiler / cmm / ZipDataflow.hs
1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
2 {-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-}
3 module ZipDataflow
4 ( Answer(..)
5 , BComputation(..), BAnalysis, BTransformation, BFunctionalTransformation
6 , BPass, BUnlimitedPass
7 , FComputation(..), FAnalysis, FTransformation, FPass, FUnlimitedPass
8 , LastOutFacts(..)
9 , DebugNodes
10 , anal_b, a_t_b, a_ft_b, a_ft_b_unlimited, ignore_transactions_b
11 , anal_f, a_t_f
12 , run_b_anal, run_f_anal
13 , refine_f_anal, refine_b_anal, fold_edge_facts_b, fold_edge_facts_with_nodes_b
14 , b_rewrite, f_rewrite
15 , solve_graph_b, solve_graph_f
16 )
17 where
18
19 import CmmTx
20 import DFMonad
21 import ZipCfg hiding (freshBlockId) -- use version from DFMonad
22 import qualified ZipCfg as G
23
24 import Outputable
25 import Panic
26 import UniqFM
27 import UniqSupply
28
29 import Control.Monad
30 import Maybe
31
32 {-
33
34 \section{A very polymorphic infrastructure for dataflow problems}
35
36 This module presents a framework for solving iterative dataflow
37 problems.
38 There are two major submodules: one for forward problems and another
39 for backward problems.
40 Both modules incorporate the composition framework developed by
41 Lerner, Grove, and Chambers.
42 They also support a \emph{transaction limit}, which enables the
43 binary-search debugging technique developed by Whalley and Davidson
44 under the name \emph{vpoiso}.
45 Transactions may either be known to the individual dataflow solvers or
46 may be managed by the framework.
47 -}
48
49 -- | In the composition framework, a pass either produces a dataflow
50 -- fact or proposes to rewrite the graph. To make life easy for the
51 -- clients, the rewrite is given in unlabelled form, but we use
52 -- labelled form internally throughout, because it greatly simplifies
53 -- the implementation not to have the first block be a special case
54 -- edverywhere.
55
56 data Answer m l a = Dataflow a | Rewrite (Graph m l)
57
58
59 {-
60
61 \subsection {Descriptions of dataflow passes}
62
63 \paragraph{Passes for backward dataflow problems}
64
65 The computation of a fact is the basis of a dataflow pass.
66 A~computation takes not one but two type parameters:
67 \begin{itemize}
68 \item
69 Type parameter [['i]] is an input, from which it should be possible to
70 derived a dataflow fact of interest.
71 For example, [['i]] might be equal to a fact, or it might be a tuple
72 of which one element is a fact.
73 \item
74 Type parameter [['o]] is an output, or possibly a function from
75 [[txlimit]] to an output
76 \end{itemize}
77 Backward analyses compute [[in]] facts (facts on inedges).
78 <<exported types for backward analyses>>=
79
80 -}
81
82 data BComputation middle last input output = BComp
83 { bc_name :: String
84 , bc_exit_in :: output
85 , bc_last_in :: (BlockId -> input) -> last -> output
86 , bc_middle_in :: input -> middle -> output
87 , bc_first_in :: input -> BlockId -> output
88 }
89
90 -- | From these elements we build several kinds of passes:
91 -- * A pure analysis computes a fact, using that fact as input and output.
92 -- * A pure transformation computes no facts but only changes the graph.
93 -- * A fully general pass both computes a fact and rewrites the graph,
94 -- respecting the current transaction limit.
95
96 type BAnalysis m l a = BComputation m l a a
97 type BTransformation m l a = BComputation m l a (Maybe (UniqSM (Graph m l)))
98 type BFunctionalTransformation m l a = BComputation m l a (Maybe (Graph m l))
99
100 type BPass m l a = BComputation m l a (Txlimit -> DFM a (Answer m l a))
101 type BUnlimitedPass m l a = BComputation m l a ( DFM a (Answer m l a))
102
103 {-
104 \paragraph{Passes for forward dataflow problems}
105
106 A forward dataflow pass has a similar structure, but the details are
107 different. In particular, the output fact from a [[last]] node has a
108 higher-order representation: it takes a function that mutates a
109 [[uid]] to account for the new fact, then performs the necessary
110 mutation on every successor of the last node. We therefore have two
111 kinds of type parameter for outputs: output from a [[middle]] node
112 is~[[outmid]], and output from a [[last]] node is~[[outlast]].
113 -}
114
115 data FComputation middle last input outmid outlast = FComp
116 { fc_name :: String
117 , fc_first_out :: input -> BlockId -> outmid
118 , fc_middle_out :: input -> middle -> outmid
119 , fc_last_outs :: input -> last -> outlast
120 , fc_exit_outs :: input -> outlast
121 }
122
123 -- | The notions of analysis, pass, and transformation are analogous to the
124 -- backward case.
125
126 newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
127 -- ^ These are facts flowing out of a last node to the node's successors.
128 -- They are either to be set (if they pertain to the graph currently
129 -- under analysis) or propagated out of a sub-analysis
130
131 type FAnalysis m l a = FComputation m l a a (LastOutFacts a)
132 type FTransformation m l a = FComputation m l a (Maybe (UniqSM (Graph m l)))
133 (Maybe (UniqSM (Graph m l)))
134 type FPass m l a = FComputation m l a
135 (Txlimit -> DFM a (Answer m l a))
136 (Txlimit -> DFM a (Answer m l (LastOutFacts a)))
137
138 type FUnlimitedPass m l a = FComputation m l a
139 (DFM a (Answer m l a))
140 (DFM a (Answer m l (LastOutFacts a)))
141
142 {-
143 \paragraph{Composing passes}
144
145 Both forward and backward engines share a handful of functions for
146 composing analyses, transformations, and passes.
147
148 We can make an analysis pass, or we can
149 combine a related analysis and transformation into a full pass.
150 -}
151
152 anal_b :: BAnalysis m l a -> BPass m l a
153 a_t_b :: BAnalysis m l a -> BTransformation m l a -> BPass m l a
154 a_ft_b :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a
155 a_ft_b_unlimited
156 :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a
157 -- ^ Ignores transaction limits. Could produce a BUnlimitedPass statically,
158 -- but that would cost too much code in the implementation for a
159 -- static distinction that is not worth so much.
160 ignore_transactions_b :: BUnlimitedPass m l a -> BPass m l a
161
162
163
164 anal_f :: FAnalysis m l a -> FPass m l a
165 a_t_f :: FAnalysis m l a -> FTransformation m l a -> FPass m l a
166
167
168 {-
169 \paragraph {Running the dataflow engine}
170
171 Every function for running analyses has two forms, because for a
172 forward analysis, we supply an entry fact, whereas for a backward
173 analysis, we don't need to supply an exit fact (because a graph for a
174 procedure doesn't have an exit node).
175 It's possible we could make these things more regular.
176 -}
177
178 -- | The analysis functions set properties on unique IDs.
179
180 run_b_anal :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) =>
181 BAnalysis m l a -> LGraph m l -> DFA a ()
182 run_f_anal :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) =>
183 FAnalysis m l a -> a -> LGraph m l -> DFA a ()
184 -- ^ extra parameter is the entry fact
185
186 -- | Rematerialize results of analysis for use elsewhere. Simply applies a
187 -- fold function to every edge fact, in reverse postorder dfs. The facts
188 -- should already have been computed into the monady by run_b_anal or b_rewrite.
189 fold_edge_facts_b
190 :: LastNode l =>
191 (a -> b -> b) -> BAnalysis m l a -> LGraph m l -> (BlockId -> a) -> b -> b
192
193 fold_edge_facts_with_nodes_b :: LastNode l
194 => (l -> a -> b -> b) -- ^ inedge to last node
195 -> (m -> a -> b -> b) -- ^ inedge to middle node
196 -> (BlockId -> a -> b -> b) -- ^ fact at label
197 -> BAnalysis m l a -- ^ backwards analysis
198 -> LGraph m l -- ^ graph
199 -> (BlockId -> a) -- ^ solution to bwd anal
200 -> b -> b
201
202
203 -- | It can be useful to refine the results of an existing analysis,
204 -- or for example to use the outcome of a forward analsysis in a
205 -- backward analysis. These functions can also be used to compute a
206 -- fixed point iteratively starting from somewhere other than bottom
207 -- (as in the reachability analysis done for proc points).
208
209 class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
210
211 refine_f_anal :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) =>
212 FAnalysis m l a -> LGraph m l -> DFA a () -> DFA a ()
213
214 refine_b_anal :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) =>
215 BAnalysis m l a -> LGraph m l -> DFA a () -> DFA a ()
216
217 b_rewrite :: (DebugNodes m l, Outputable a) =>
218 BPass m l a -> LGraph m l -> DFM a (LGraph m l)
219 f_rewrite :: (DebugNodes m l, LastNode l, Outputable m, Outputable a) =>
220 FPass m l a -> a -> LGraph m l -> DFM a (LGraph m l)
221 -- ^ extra parameter is the entry fact
222
223 -- | If the solution to a problem is already sitting in a monad, we
224 -- should be able to take a short cut and just rewrite it in one pass.
225 -- But not yet implemented.
226
227 {-
228 f_rewrite_solved :: (LastNode l, Outputable m, Outputable a) =>
229 FPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l)
230 b_rewrite_solved :: (LastNode l, Outputable m, Outputable a) =>
231 BPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l)
232 -}
233
234 -- ===================== IMPLEMENTATION ======================--
235
236 -- | Here's a function to run an action on blocks until we reach a fixed point.
237 run :: (DataflowAnalysis anal, Monad (anal a), Outputable a, DebugNodes m l) =>
238 String -> String -> anal a () -> (b -> Block m l -> anal a b) ->
239 b -> [Block m l] -> anal a b
240 run dir name set_entry do_block b blocks =
241 do { set_entry; show_blocks $ iterate (1::Int) }
242 where
243 -- N.B. Each iteration starts with the same transaction limit;
244 -- only the rewrites in the final iteration actually count
245 trace_block b block = my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $
246 do_block b block
247 iterate n =
248 do { markFactsUnchanged
249 ; b <- foldM trace_block b blocks
250 ; changed <- factsStatus
251 ; facts <- allFacts
252 ; let depth = 0 -- was nesting depth
253 ; ppIter depth n $
254 case changed of
255 NoChange -> unchanged depth $ return b
256 SomeChange ->
257 pprFacts depth n facts $
258 if n < 1000 then iterate (n+1)
259 else panic $ msg n
260 }
261 msg n = concat [name, " didn't converge in ", show n, " " , dir,
262 " iterations"]
263 my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
264 ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
265 pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
266 unchanged depth = my_nest depth (text "facts are unchanged")
267
268 pprFacts depth n env =
269 my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
270 (nest 2 $ vcat $ map pprFact $ ufmToList env))
271 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
272 graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
273 show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
274 pprBlock (Block id t) = nest 2 (pprFact (id, t))
275
276 {-
277 \subsection{Backward problems}
278
279 In a backward problem, we compute \emph{in} facts from \emph{out}
280 facts. The analysis gives us [[exit_in]], [[last_in]], [[middle_in]],
281 and [[first_in]], each of which computes an \emph{in} fact for one
282 kind of node. We provide [[head_in]], which computes the \emph{in}
283 fact for a first node followed by zero or more middle nodes.
284
285 We don't compute and return the \emph{in} fact for block; instead, we
286 use [[setFact]] to attach that fact to the block's unique~ID.
287 We iterate until no more facts have changed.
288 -}
289 run_b_anal comp graph =
290 refine_b_anal comp graph (return ())
291 -- for a backward analysis, everything is initially bottom
292
293 refine_b_anal comp graph initial =
294 run "backward" (bc_name comp) initial set_block_fact () blocks
295 where
296 blocks = reverse (postorder_dfs graph)
297 set_block_fact () b@(G.Block id _) =
298 let (h, l) = G.goto_end (G.unzip b) in
299 do env <- factsEnv
300 let block_in = head_in h (last_in comp env l) -- 'in' fact for the block
301 setFact id block_in
302 head_in (G.ZHead h m) out = head_in h (bc_middle_in comp out m)
303 head_in (G.ZFirst id) out = bc_first_in comp out id
304
305 last_in :: BComputation m l i o -> (BlockId -> i) -> G.ZLast l -> o
306 last_in comp env (G.LastOther l) = bc_last_in comp env l
307 last_in comp _ (G.LastExit) = bc_exit_in comp
308
309 ------ we can now pass those facts elsewhere
310 fold_edge_facts_b f comp graph env z =
311 foldl fold_block_facts z (postorder_dfs graph)
312 where
313 fold_block_facts z b =
314 let (h, l) = G.goto_end (G.unzip b)
315 in head_fold h (last_in comp env l) z
316 head_fold (G.ZHead h m) out z = head_fold h (bc_middle_in comp out m) (f out z)
317 head_fold (G.ZFirst id) out z = f (bc_first_in comp out id) (f out z)
318
319 fold_edge_facts_with_nodes_b fl fm ff comp graph env z =
320 foldl fold_block_facts z (postorder_dfs graph)
321 where
322 fold_block_facts z b =
323 let (h, l) = G.goto_end (G.unzip b)
324 in' = last_in comp env l
325 z' = case l of { G.LastExit -> z ; G.LastOther l -> fl l in' z }
326 in head_fold h in' z'
327 head_fold (G.ZHead h m) out z =
328 let a = bc_middle_in comp out m
329 z' = fm m a z
330 in head_fold h a z'
331 head_fold (G.ZFirst id) out z =
332 let a = bc_first_in comp out id
333 z' = ff id a z
334 in z'
335
336
337 -- | In the general case we solve a graph in the context of a larger subgraph.
338 -- To do this, we need a locally modified computation that allows an
339 -- ``exit fact'' to flow into the exit node.
340
341 comp_with_exit_b :: BComputation m l i (Txlimit -> DFM f (Answer m l o)) -> o ->
342 BComputation m l i (Txlimit -> DFM f (Answer m l o))
343 comp_with_exit_b comp exit_fact =
344 comp { bc_exit_in = \_txlim -> return $ Dataflow $ exit_fact }
345
346 -- | Given this function, we can now solve a graph simply by doing a
347 -- backward analysis on the modified computation. Note we have to be
348 -- very careful with 'Rewrite'. Either a rewrite is going to
349 -- participate, in which case we mark the graph rerewritten, or we're
350 -- going to analysis the proposed rewrite and then throw away
351 -- everything but the answer, in which case it's a 'subAnalysis'. A
352 -- Rewrite should always use exactly one of these monadic operations.
353
354 solve_graph_b ::
355 forall m l a . (DebugNodes m l, Outputable a) =>
356 BPass m l a -> Txlimit -> G.LGraph m l -> a -> DFM a (Txlimit, a)
357 solve_graph_b comp txlim graph exit_fact =
358 general_backward (comp_with_exit_b comp exit_fact) txlim graph
359 where
360 general_backward :: BPass m l a -> Txlimit -> G.LGraph m l -> DFM a (Txlimit, a)
361 general_backward comp txlim graph =
362 let set_block_fact :: Txlimit -> G.Block m l -> DFM a Txlimit
363 set_block_fact txlim b =
364 do { (txlim, block_in) <-
365 let (h, l) = G.goto_end (G.unzip b) in
366 factsEnv >>= \env -> last_in comp env l txlim >>= \x ->
367 case x of
368 Dataflow a -> head_in txlim h a
369 Rewrite g ->
370 do { bot <- botFact
371 ; g <- lgraphOfGraph g
372 ; (txlim, a) <- subAnalysis' $
373 solve_graph_b comp (txlim-1) g bot
374 ; head_in txlim h a }
375 ; my_trace "result of" (text (bc_name comp) <+>
376 text "on" <+> ppr (G.blockId b) <+> text "is" <+> ppr block_in) $
377 setFact (G.blockId b) block_in
378 ; return txlim
379 }
380 head_in txlim (G.ZHead h m) out =
381 bc_middle_in comp out m txlim >>= \x -> case x of
382 Dataflow a -> head_in txlim h a
383 Rewrite g ->
384 do { g <- lgraphOfGraph g
385 ; (txlim, a) <- subAnalysis' $ solve_graph_b comp (txlim-1) g out
386 ; my_trace "Rewrote middle node" (f4sep [ppr m, text "to", ppr g]) $
387 head_in txlim h a }
388 head_in txlim (G.ZFirst id) out =
389 bc_first_in comp out id txlim >>= \x -> case x of
390 Dataflow a -> return (txlim, a)
391 Rewrite g -> do { g <- lgraphOfGraph g
392 ; subAnalysis' $ solve_graph_b comp (txlim-1) g out }
393
394 in do { txlim <-
395 run "backward" (bc_name comp) (return ()) set_block_fact txlim blocks
396 ; a <- getFact (G.gr_entry graph)
397 ; facts <- allFacts
398 ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $
399 return (txlim, a) }
400
401 blocks = reverse (G.postorder_dfs graph)
402 pprFacts g env a = (ppr a <+> text "with") $$ vcat (pprLgraph g : map pprFact (ufmToList env))
403 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
404
405
406 lgraphOfGraph :: G.Graph m l -> DFM f (G.LGraph m l)
407 lgraphOfGraph g =
408 do id <- freshBlockId "temporary id for dataflow analysis"
409 return $ labelGraph id g
410
411 labelGraph :: BlockId -> G.Graph m l -> G.LGraph m l
412 labelGraph id (Graph tail blocks) = LGraph id (insertBlock (Block id tail) blocks)
413
414 {-
415 We solve and rewrite in two passes: the first pass iterates to a fixed
416 point to reach a dataflow solution, and the second pass uses that
417 solution to rewrite the graph.
418
419 The
420 key job is done by [[propagate]], which propagates a fact of type~[[a]]
421 between a head and tail.
422 The tail is in final form; the head is still to be rewritten.
423 -}
424
425 solve_and_rewrite_b ::
426 forall m l a. (DebugNodes m l, Outputable a) =>
427 BPass m l a -> Txlimit -> LGraph m l -> a -> DFM a (Txlimit, a, LGraph m l)
428
429 solve_and_rewrite_b comp txlim graph exit_fact =
430 do { (_, a) <- solve_graph_b comp txlim graph exit_fact -- pass 1
431 ; facts <- allFacts
432 ; (txlim, g) <- -- pass 2
433 my_trace "Solution to graph after pass 1 is" (pprFacts graph facts) $
434 backward_rewrite (comp_with_exit_b comp exit_fact) txlim graph
435 ; facts <- allFacts
436 ; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $
437 return (txlim, a, g) }
438 where
439 pprFacts g env = vcat (pprLgraph g : map pprFact (ufmToList env))
440 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
441 eid = G.gr_entry graph
442 backward_rewrite comp txlim graph =
443 rewrite_blocks comp txlim emptyBlockEnv $ reverse (G.postorder_dfs graph)
444 rewrite_blocks ::
445 BPass m l a -> Txlimit ->
446 BlockEnv (Block m l) -> [Block m l] -> DFM a (Txlimit,G.LGraph m l)
447 rewrite_blocks _comp txlim rewritten [] = return (txlim, G.LGraph eid rewritten)
448 rewrite_blocks comp txlim rewritten (b:bs) =
449 let rewrite_next_block txlim =
450 let (h, l) = G.goto_end (G.unzip b) in
451 factsEnv >>= \env -> last_in comp env l txlim >>= \x -> case x of
452 Dataflow a -> propagate txlim h a (G.ZLast l) rewritten
453 Rewrite g -> -- see Note [Rewriting labelled LGraphs]
454 do { bot <- botFact
455 ; g <- lgraphOfGraph g
456 ; (txlim, a, g') <- solve_and_rewrite_b comp (txlim-1) g bot
457 ; let G.Graph t new_blocks = G.remove_entry_label g'
458 ; markGraphRewritten
459 ; let rewritten' = plusUFM new_blocks rewritten
460 ; -- continue at entry of g
461 propagate txlim h a t rewritten'
462 }
463 propagate :: Txlimit -> G.ZHead m -> a -> G.ZTail m l ->
464 BlockEnv (Block m l) -> DFM a (Txlimit, G.LGraph m l)
465 propagate txlim (G.ZHead h m) out tail rewritten =
466 bc_middle_in comp out m txlim >>= \x -> case x of
467 Dataflow a -> propagate txlim h a (G.ZTail m tail) rewritten
468 Rewrite g ->
469 do { g <- lgraphOfGraph g
470 ; (txlim, a, g') <- solve_and_rewrite_b comp (txlim-1) g out
471 ; markGraphRewritten
472 ; let (t, g'') = G.splice_tail g' tail
473 ; let rewritten' = plusUFM (G.gr_blocks g'') rewritten
474 ; my_trace "Rewrote middle node" (f4sep [ppr m, text "to", ppr g]) $
475 propagate txlim h a t rewritten' }
476 propagate txlim h@(G.ZFirst id) out tail rewritten =
477 bc_first_in comp out id txlim >>= \x -> case x of
478 Dataflow a ->
479 let b = G.Block id tail in
480 do { checkFactMatch id a
481 ; rewrite_blocks comp txlim (extendBlockEnv rewritten id b) bs }
482 Rewrite fg ->
483 do { g <- lgraphOfGraph fg
484 ; (txlim, a, g') <- solve_and_rewrite_b comp (txlim-1) g out
485 ; markGraphRewritten
486 ; let (t, g'') = G.splice_tail g' tail
487 ; let rewritten' = plusUFM (G.gr_blocks g'') rewritten
488 ; my_trace "Rewrote label " (f4sep [ppr id, text "to", ppr g]) $
489 propagate txlim h a t rewritten' }
490 in rewrite_next_block txlim
491
492 b_rewrite comp g =
493 do { txlim <- liftTx txRemaining
494 ; bot <- botFact
495 ; (txlim', _, gc) <- solve_and_rewrite_b comp txlim g bot
496 ; liftTx $ txDecrement (bc_name comp) txlim txlim'
497 ; return gc
498 }
499
500 {-
501 This debugging stuff is left over from imperative-land.
502 It might be useful one day if I learn how to cheat the IO monad!
503
504 debug_b :: (Outputable m, Outputable l, Outputable a) => BPass m l a -> BPass m l a
505
506 let debug s (f, comp) =
507 let pr = Printf.eprintf in
508 let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
509 let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
510 let wrap f nodestring node txlim =
511 let answer = f node txlim in
512 let () = match answer with
513 | Dataflow a -> fact "in " (nodestring node) a
514 | Rewrite g -> rewr (nodestring node) g in
515 answer in
516 let wrapout f nodestring out node txlim =
517 fact "out" (nodestring node) out;
518 wrap (f out) nodestring node txlim in
519 let last_in = wrap comp.last_in (RS.rtl << G.last_instr) in
520 let middle_in = wrapout comp.middle_in (RS.rtl << G.mid_instr) in
521 let first_in =
522 let first = function G.Entry -> "<entry>" | G.Label ((u, l), _, _) -> l in
523 wrapout comp.first_in first in
524 f, { comp with last_in = last_in; middle_in = middle_in; first_in = first_in; }
525 -}
526
527 anal_b comp = comp { bc_last_in = wrap2 $ bc_last_in comp
528 , bc_exit_in = wrap0 $ bc_exit_in comp
529 , bc_middle_in = wrap2 $ bc_middle_in comp
530 , bc_first_in = wrap2 $ bc_first_in comp }
531 where wrap2 f out node _txlim = return $ Dataflow (f out node)
532 wrap0 fact _txlim = return $ Dataflow fact
533
534 ignore_transactions_b comp =
535 comp { bc_last_in = wrap2 $ bc_last_in comp
536 , bc_exit_in = wrap0 $ bc_exit_in comp
537 , bc_middle_in = wrap2 $ bc_middle_in comp
538 , bc_first_in = wrap2 $ bc_first_in comp }
539 where wrap2 f out node _txlim = f out node
540 wrap0 fact _txlim = fact
541
542 answer' :: (b -> DFM f (Graph m l)) -> Txlimit -> Maybe b -> a -> DFM f (Answer m l a)
543 answer' lift txlim r a =
544 case r of Just gc | txlim > 0 -> do { g <- lift gc; return $ Rewrite g }
545 _ -> return $ Dataflow a
546
547 unlimited_answer'
548 :: (b -> DFM f (Graph m l)) -> Txlimit -> Maybe b -> a -> DFM f (Answer m l a)
549 unlimited_answer' lift _txlim r a =
550 case r of Just gc -> do { g <- lift gc; return $ Rewrite g }
551 _ -> return $ Dataflow a
552
553 combine_a_t_with :: (Txlimit -> Maybe b -> a -> DFM a (Answer m l a)) ->
554 BAnalysis m l a -> BComputation m l a (Maybe b) ->
555 BPass m l a
556 combine_a_t_with answer anal tx =
557 let last_in env l txlim =
558 answer txlim (bc_last_in tx env l) (bc_last_in anal env l)
559 exit_in txlim = answer txlim (bc_exit_in tx) (bc_exit_in anal)
560 middle_in out m txlim =
561 answer txlim (bc_middle_in tx out m) (bc_middle_in anal out m)
562 first_in out f txlim =
563 answer txlim (bc_first_in tx out f) (bc_first_in anal out f)
564 in BComp { bc_name = concat [bc_name anal, " and ", bc_name tx]
565 , bc_last_in = last_in, bc_middle_in = middle_in
566 , bc_first_in = first_in, bc_exit_in = exit_in }
567
568 a_t_b = combine_a_t_with (answer' liftUSM)
569 a_ft_b = combine_a_t_with (answer' return)
570 a_ft_b_unlimited = combine_a_t_with (unlimited_answer' return)
571
572
573 -- =============== FORWARD ================
574
575 -- | We don't compute and return the \emph{in} fact for block; instead, we
576 -- use [[P.set]] to attach that fact to the block's unique~ID.
577 -- We iterate until no more facts have changed.
578
579 dump_things :: Bool
580 dump_things = False
581
582 my_trace :: String -> SDoc -> a -> a
583 my_trace = if dump_things then pprTrace else \_ _ a -> a
584
585 run_f_anal comp entry_fact graph = refine_f_anal comp graph set_entry
586 where set_entry = setFact (G.gr_entry graph) entry_fact
587
588 refine_f_anal comp graph initial =
589 run "forward" (fc_name comp) initial set_successor_facts () blocks
590 where blocks = G.postorder_dfs graph
591 set_successor_facts () (G.Block id t) =
592 let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t
593 forward in' (G.ZLast l) = setEdgeFacts (last_outs comp in' l)
594 _blockname = if id == G.gr_entry graph then "<entry>" else show id
595 in getFact id >>= \a -> forward (fc_first_out comp a id) t
596 setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs
597 setEdgeFact (id, a) = setFact id a
598
599 last_outs :: FComputation m l i om ol -> i -> G.ZLast l -> ol
600 last_outs comp i (G.LastExit) = fc_exit_outs comp i
601 last_outs comp i (G.LastOther l) = fc_last_outs comp i l
602
603 -- | In the general case we solve a graph in the context of a larger subgraph.
604 -- To do this, we need a locally modified computation that allows an
605 -- ``exit fact'' to flow out of the exit node. We pass in a fresh BlockId
606 -- to which the exit fact can flow
607
608 comp_with_exit_f :: FPass m l a -> BlockId -> FPass m l a
609 comp_with_exit_f comp exit_fact_id = comp { fc_exit_outs = exit_outs }
610 where exit_outs in' _txlimit =
611 return $ Dataflow $ LastOutFacts [(exit_fact_id, in')]
612
613 -- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a
614 -- forward analysis on the modified computation.
615 solve_graph_f ::
616 forall m l a . (DebugNodes m l, Outputable a) =>
617 FPass m l a -> Txlimit -> G.LGraph m l -> a ->
618 DFM a (Txlimit, a, LastOutFacts a)
619 solve_graph_f comp txlim g in_fact =
620 do { exit_fact_id <- freshBlockId "proxy for exit node"
621 ; txlim <- general_forward (comp_with_exit_f comp exit_fact_id) txlim in_fact g
622 ; a <- getFact exit_fact_id
623 ; outs <- lastOutFacts
624 ; forgetFact exit_fact_id -- close space leak
625 ; return (txlim, a, LastOutFacts outs) }
626 where
627 general_forward :: FPass m l a -> Txlimit -> a -> G.LGraph m l -> DFM a Txlimit
628 general_forward comp txlim entry_fact graph =
629 let blocks = G.postorder_dfs g
630 is_local id = isJust $ lookupBlockEnv (G.gr_blocks g) id
631 set_or_save :: LastOutFacts a -> DFM a ()
632 set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
633 set_or_save_one (id, a) =
634 if is_local id then setFact id a else addLastOutFact (id, a)
635 set_entry = setFact (G.gr_entry graph) entry_fact
636
637 set_successor_facts txlim b =
638 let set_tail_facts txlim in' (G.ZTail m t) =
639 my_trace "Solving middle node" (ppr m) $
640 fc_middle_out comp in' m txlim >>= \ x -> case x of
641 Dataflow a -> set_tail_facts txlim a t
642 Rewrite g ->
643 do g <- lgraphOfGraph g
644 (txlim, out, last_outs) <- subAnalysis' $
645 solve_graph_f comp (txlim-1) g in'
646 set_or_save last_outs
647 set_tail_facts txlim out t
648 set_tail_facts txlim in' (G.ZLast l) =
649 last_outs comp in' l txlim >>= \x -> case x of
650 Dataflow outs -> do { set_or_save outs; return txlim }
651 Rewrite g ->
652 do g <- lgraphOfGraph g
653 (txlim, _, last_outs) <- subAnalysis' $
654 solve_graph_f comp (txlim-1) g in'
655 set_or_save last_outs
656 return txlim
657 G.Block id t = b
658 in do idfact <- getFact id
659 infact <- fc_first_out comp idfact id txlim
660 case infact of Dataflow a -> set_tail_facts txlim a t
661 Rewrite g ->
662 do g <- lgraphOfGraph g
663 (txlim, out, last_outs) <- subAnalysis' $
664 solve_graph_f comp (txlim-1) g idfact
665 set_or_save last_outs
666 set_tail_facts txlim out t
667 in run "forward" (fc_name comp) set_entry set_successor_facts txlim blocks
668
669
670
671 {-
672 We solve and rewrite in two passes: the first pass iterates to a fixed
673 point to reach a dataflow solution, and the second pass uses that
674 solution to rewrite the graph.
675
676 The key job is done by [[propagate]], which propagates a fact of type~[[a]]
677 between a head and tail.
678 The tail is in final form; the head is still to be rewritten.
679 -}
680 solve_and_rewrite_f ::
681 forall m l a . (DebugNodes m l, Outputable a) =>
682 FPass m l a -> Txlimit -> LGraph m l -> a -> DFM a (Txlimit, a, LGraph m l)
683 solve_and_rewrite_f comp txlim graph in_fact =
684 do solve_graph_f comp txlim graph in_fact -- pass 1
685 exit_id <- freshBlockId "proxy for exit node"
686 (txlim, g) <- forward_rewrite (comp_with_exit_f comp exit_id) txlim graph in_fact
687 exit_fact <- getFact exit_id
688 return (txlim, exit_fact, g)
689
690 forward_rewrite ::
691 forall m l a . (DebugNodes m l, Outputable a) =>
692 FPass m l a -> Txlimit -> G.LGraph m l -> a -> DFM a (Txlimit, G.LGraph m l)
693 forward_rewrite comp txlim graph entry_fact =
694 do setFact eid entry_fact
695 rewrite_blocks txlim emptyBlockEnv (G.postorder_dfs graph)
696 where
697 eid = G.gr_entry graph
698 is_local id = isJust $ lookupBlockEnv (G.gr_blocks graph) id
699 set_or_save :: LastOutFacts a -> DFM a ()
700 set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
701 set_or_save_one (id, a) =
702 if is_local id then checkFactMatch id a
703 else panic "set fact outside graph during rewriting pass?!"
704
705 rewrite_blocks ::
706 Txlimit -> BlockEnv (Block m l) -> [Block m l] -> DFM a (Txlimit, LGraph m l)
707 rewrite_blocks txlim rewritten [] = return (txlim, G.LGraph eid rewritten)
708 rewrite_blocks txlim rewritten (G.Block id t : bs) =
709 do id_fact <- getFact id
710 first_out <- fc_first_out comp id_fact id txlim
711 case first_out of
712 Dataflow a -> propagate txlim (G.ZFirst id) a t rewritten bs
713 Rewrite fg -> do { markGraphRewritten
714 ; rewrite_blocks (txlim-1) rewritten
715 (G.postorder_dfs (labelGraph id fg) ++ bs) }
716 propagate :: Txlimit -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
717 [G.Block m l] -> DFM a (Txlimit, G.LGraph m l)
718 propagate txlim h in' (G.ZTail m t) rewritten bs =
719 my_trace "Rewriting middle node" (ppr m) $
720 do fc_middle_out comp in' m txlim >>= \x -> case x of
721 Dataflow a -> propagate txlim (G.ZHead h m) a t rewritten bs
722 Rewrite g ->
723 my_trace "Rewriting middle node...\n" empty $
724 do g <- lgraphOfGraph g
725 (txlim, a, g) <- solve_and_rewrite_f comp (txlim-1) g in'
726 markGraphRewritten
727 my_trace "Rewrite of middle node completed\n" empty $
728 let (g', h') = G.splice_head h g in
729 propagate txlim h' a t (plusUFM (G.gr_blocks g') rewritten) bs
730 propagate txlim h in' (G.ZLast l) rewritten bs =
731 do last_outs comp in' l txlim >>= \x -> case x of
732 Dataflow outs ->
733 do set_or_save outs
734 let b = G.zip (G.ZBlock h (G.ZLast l))
735 rewrite_blocks txlim (G.insertBlock b rewritten) bs
736 Rewrite g ->
737 -- could test here that [[exits g = exits (G.Entry, G.ZLast l)]]
738 {- if Debug.on "rewrite-last" then
739 Printf.eprintf "ZLast node %s rewritten to:\n"
740 (RS.rtl (G.last_instr l)); -}
741 do g <- lgraphOfGraph g
742 (txlim, _, g) <- solve_and_rewrite_f comp (txlim-1) g in'
743 markGraphRewritten
744 let g' = G.splice_head_only h g
745 rewrite_blocks txlim (plusUFM (G.gr_blocks g') rewritten) bs
746
747 f_rewrite comp entry_fact g =
748 do { txlim <- liftTx txRemaining
749 ; (txlim', _, gc) <- solve_and_rewrite_f comp txlim g entry_fact
750 ; liftTx $ txDecrement (fc_name comp) txlim txlim'
751 ; return gc
752 }
753
754
755 {-
756 debug_f :: (Outputable m, Outputable l, Outputable a) => FPass m l a -> FPass m l a
757
758 let debug s (f, comp) =
759 let pr = Printf.eprintf in
760 let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
761 let setter dir node run_sets set =
762 run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in
763 let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
764 let wrap f nodestring wrap_answer in' node txlim =
765 fact "in " (nodestring node) in';
766 wrap_answer (nodestring node) (f in' node txlim)
767 and wrap_fact n answer =
768 let () = match answer with
769 | Dataflow a -> fact "out" n a
770 | Rewrite g -> rewr n g in
771 answer
772 and wrap_setter n answer =
773 match answer with
774 | Dataflow set -> Dataflow (setter "out" n set)
775 | Rewrite g -> (rewr n g; Rewrite g) in
776 let middle_out = wrap comp.middle_out (RS.rtl << G.mid_instr) wrap_fact in
777 let last_outs = wrap comp.last_outs (RS.rtl << G.last_instr) wrap_setter in
778 f, { comp with last_outs = last_outs; middle_out = middle_out; }
779 -}
780
781 anal_f comp = comp { fc_first_out = wrap2 $ fc_first_out comp
782 , fc_middle_out = wrap2 $ fc_middle_out comp
783 , fc_last_outs = wrap2 $ fc_last_outs comp
784 , fc_exit_outs = wrap1 $ fc_exit_outs comp
785 }
786 where wrap2 f out node _txlim = return $ Dataflow (f out node)
787 wrap1 f fact _txlim = return $ Dataflow (f fact)
788
789
790 a_t_f anal tx =
791 let answer = answer' liftUSM
792 first_out in' id txlim =
793 answer txlim (fc_first_out tx in' id) (fc_first_out anal in' id)
794 middle_out in' m txlim =
795 answer txlim (fc_middle_out tx in' m) (fc_middle_out anal in' m)
796 last_outs in' l txlim =
797 answer txlim (fc_last_outs tx in' l) (fc_last_outs anal in' l)
798 exit_outs in' txlim = undefined
799 answer txlim (fc_exit_outs tx in') (fc_exit_outs anal in')
800 in FComp { fc_name = concat [fc_name anal, " and ", fc_name tx]
801 , fc_last_outs = last_outs, fc_middle_out = middle_out
802 , fc_first_out = first_out, fc_exit_outs = exit_outs }
803
804
805 {- Note [Rewriting labelled LGraphs]
806 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
807 It's hugely annoying that we get in an LGraph and in order to solve it
808 we have to slap on a new label which we then immediately strip off.
809 But the alternative is to have all the iterative solvers work on
810 Graphs, and then suddenly instead of a single case (ZBlock) every
811 solver has to deal with two cases (ZBlock and ZTail). So until
812 somebody comes along who is smart enough to do this and still leave
813 the code understandable for mortals, it stays as it is.
814
815 (A good place to start changing things would be to figure out what is
816 the analogue of postorder_dfs for Graphs, and to figure out what
817 higher-order functions would do for dealing with the resulting
818 sequences of *things*.)
819 -}
820
821 f4sep :: [SDoc] -> SDoc
822 f4sep [] = fsep []
823 f4sep (d:ds) = fsep (d : map (nest 4) ds)
824
825 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
826 m f a -> m f a
827 subAnalysis' m =
828 do { a <- subAnalysis $
829 do { a <- m; facts <- allFacts
830 ; my_trace "after sub-analysis facts are" (pprFacts facts) $
831 return a }
832 ; facts <- allFacts
833 ; my_trace "in parent analysis facts are" (pprFacts facts) $
834 return a }
835 where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
836 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)