1 {-# LANGUAGE MultiParamTypeClasses #-}
4 , BComputation(..), BAnalysis, BTransformation, BFunctionalTransformation
5 , BPass, BUnlimitedPass
6 , FComputation(..), FAnalysis, FTransformation, FPass, FUnlimitedPass
9 , anal_b, a_t_b, a_ft_b, a_ft_b_unlimited, ignore_transactions_b
11 , run_b_anal, run_f_anal
12 , refine_f_anal, refine_b_anal, fold_edge_facts_b, fold_edge_facts_with_nodes_b
13 , b_rewrite, f_rewrite
14 , solve_graph_b, solve_graph_f
21 import qualified ZipCfg as G
31 #include "HsVersions.h"
35 \section{A very polymorphic infrastructure for dataflow problems}
37 This module presents a framework for solving iterative dataflow
39 There are two major submodules: one for forward problems and another
40 for backward problems.
41 Both modules incorporate the composition framework developed by
42 Lerner, Grove, and Chambers.
43 They also support a \emph{transaction limit}, which enables the
44 binary-search debugging technique developed by Whalley and Davidson
45 under the name \emph{vpoiso}.
46 Transactions may either be known to the individual dataflow solvers or
47 may be managed by the framework.
50 -- | In the composition framework, a pass either produces a dataflow
51 -- fact or proposes to rewrite the graph. To make life easy for the
52 -- clients, the rewrite is given in unlabelled form, but we use
53 -- labelled form internally throughout, because it greatly simplifies
54 -- the implementation not to have the first block be a special case
57 data Answer m l a = Dataflow a | Rewrite (Graph m l)
62 \subsection {Descriptions of dataflow passes}
64 \paragraph{Passes for backward dataflow problems}
66 The computation of a fact is the basis of a dataflow pass.
67 A~computation takes not one but two type parameters:
70 Type parameter [['i]] is an input, from which it should be possible to
71 derived a dataflow fact of interest.
72 For example, [['i]] might be equal to a fact, or it might be a tuple
73 of which one element is a fact.
75 Type parameter [['o]] is an output, or possibly a function from
78 Backward analyses compute [[in]] facts (facts on inedges).
79 <<exported types for backward analyses>>=
83 data BComputation middle last input output = BComp
85 , bc_exit_in :: output
86 , bc_last_in :: (BlockId -> input) -> last -> output
87 , bc_middle_in :: input -> middle -> output
88 , bc_first_in :: input -> BlockId -> output
91 -- | From these elements we build several kinds of passes:
92 -- * A pure analysis computes a fact, using that fact as input and output.
93 -- * A pure transformation computes no facts but only changes the graph.
94 -- * A fully general pass both computes a fact and rewrites the graph,
95 -- respecting the current transaction limit.
97 type BAnalysis m l a = BComputation m l a a
98 type BTransformation m l a = BComputation m l a (Maybe (UniqSM (Graph m l)))
99 type BFunctionalTransformation m l a = BComputation m l a (Maybe (Graph m l))
101 type BPass m l a = BComputation m l a (OptimizationFuel -> DFM a (Answer m l a))
102 type BUnlimitedPass m l a = BComputation m l a ( DFM a (Answer m l a))
105 \paragraph{Passes for forward dataflow problems}
107 A forward dataflow pass has a similar structure, but the details are
108 different. In particular, the output fact from a [[last]] node has a
109 higher-order representation: it takes a function that mutates a
110 [[uid]] to account for the new fact, then performs the necessary
111 mutation on every successor of the last node. We therefore have two
112 kinds of type parameter for outputs: output from a [[middle]] node
113 is~[[outmid]], and output from a [[last]] node is~[[outlast]].
116 data FComputation middle last input outmid outlast = FComp
118 , fc_first_out :: input -> BlockId -> outmid
119 , fc_middle_out :: input -> middle -> outmid
120 , fc_last_outs :: input -> last -> outlast
121 , fc_exit_outs :: input -> outlast
124 -- | The notions of analysis, pass, and transformation are analogous to the
127 newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
128 -- ^ These are facts flowing out of a last node to the node's successors.
129 -- They are either to be set (if they pertain to the graph currently
130 -- under analysis) or propagated out of a sub-analysis
132 type FAnalysis m l a = FComputation m l a a (LastOutFacts a)
133 type FTransformation m l a = FComputation m l a (Maybe (UniqSM (Graph m l)))
134 (Maybe (UniqSM (Graph m l)))
135 type FPass m l a = FComputation m l a
136 (OptimizationFuel -> DFM a (Answer m l a))
137 (OptimizationFuel -> DFM a (Answer m l (LastOutFacts a)))
139 type FUnlimitedPass m l a = FComputation m l a
140 (DFM a (Answer m l a))
141 (DFM a (Answer m l (LastOutFacts a)))
144 \paragraph{Composing passes}
146 Both forward and backward engines share a handful of functions for
147 composing analyses, transformations, and passes.
149 We can make an analysis pass, or we can
150 combine a related analysis and transformation into a full pass.
153 anal_b :: BAnalysis m l a -> BPass m l a
154 a_t_b :: BAnalysis m l a -> BTransformation m l a -> BPass m l a
155 a_ft_b :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a
157 :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a
158 -- ^ Ignores transaction limits. Could produce a BUnlimitedPass statically,
159 -- but that would cost too much code in the implementation for a
160 -- static distinction that is not worth so much.
161 ignore_transactions_b :: BUnlimitedPass m l a -> BPass m l a
165 anal_f :: FAnalysis m l a -> FPass m l a
166 a_t_f :: FAnalysis m l a -> FTransformation m l a -> FPass m l a
170 \paragraph {Running the dataflow engine}
172 Every function for running analyses has two forms, because for a
173 forward analysis, we supply an entry fact, whereas for a backward
174 analysis, we don't need to supply an exit fact (because a graph for a
175 procedure doesn't have an exit node).
176 It's possible we could make these things more regular.
179 -- | The analysis functions set properties on unique IDs.
181 run_b_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
182 BAnalysis m l a -> LGraph m l -> DFA a ()
183 run_f_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
184 FAnalysis m l a -> a -> LGraph m l -> DFA a ()
185 -- ^ extra parameter is the entry fact
187 -- | Rematerialize results of analysis for use elsewhere. Simply applies a
188 -- fold function to every edge fact, in reverse postorder dfs. The facts
189 -- should already have been computed into the monady by run_b_anal or b_rewrite.
192 (a -> b -> b) -> BAnalysis m l a -> LGraph m l -> (BlockId -> a) -> b -> b
194 fold_edge_facts_with_nodes_b :: LastNode l
195 => (l -> a -> b -> b) -- ^ inedge to last node
196 -> (m -> a -> b -> b) -- ^ inedge to middle node
197 -> (BlockId -> a -> b -> b) -- ^ fact at label
198 -> BAnalysis m l a -- ^ backwards analysis
199 -> LGraph m l -- ^ graph
200 -> (BlockId -> a) -- ^ solution to bwd anal
204 -- | It can be useful to refine the results of an existing analysis,
205 -- or for example to use the outcome of a forward analsysis in a
206 -- backward analysis. These functions can also be used to compute a
207 -- fixed point iteratively starting from somewhere other than bottom
208 -- (as in the reachability analysis done for proc points).
210 class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
212 refine_f_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
213 FAnalysis m l a -> LGraph m l -> DFA a () -> DFA a ()
215 refine_b_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
216 BAnalysis m l a -> LGraph m l -> DFA a () -> DFA a ()
218 b_rewrite :: (DebugNodes m l, Outputable a) =>
219 BPass m l a -> LGraph m l -> DFM a (LGraph m l)
220 f_rewrite :: (DebugNodes m l, LastNode l, Outputable m, Outputable a) =>
221 FPass m l a -> a -> LGraph m l -> DFM a (LGraph m l)
222 -- ^ extra parameter is the entry fact
224 -- | If the solution to a problem is already sitting in a monad, we
225 -- should be able to take a short cut and just rewrite it in one pass.
226 -- But not yet implemented.
229 f_rewrite_solved :: (LastNode l, Outputable m, Outputable a) =>
230 FPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l)
231 b_rewrite_solved :: (LastNode l, Outputable m, Outputable a) =>
232 BPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l)
235 -- ===================== IMPLEMENTATION ======================--
237 -- | Here's a function to run an action on blocks until we reach a fixed point.
238 run :: (DataflowAnalysis anal, Monad (anal a), Outputable a, DebugNodes m l) =>
239 String -> String -> anal a () -> (b -> Block m l -> anal a b) ->
240 b -> [Block m l] -> anal a b
241 run dir name set_entry do_block b blocks =
242 do { set_entry; show_blocks $ iterate (1::Int) }
244 -- N.B. Each iteration starts with the same transaction limit;
245 -- only the rewrites in the final iteration actually count
246 trace_block b block = my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $
249 do { markFactsUnchanged
250 ; b <- foldM trace_block b blocks
251 ; changed <- factsStatus
253 ; let depth = 0 -- was nesting depth
256 NoChange -> unchanged depth $ return b
258 pprFacts depth n facts $
259 if n < 1000 then iterate (n+1)
262 msg n = concat [name, " didn't converge in ", show n, " " , dir,
264 my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
265 ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
266 pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
267 unchanged depth = my_nest depth (text "facts are unchanged")
269 pprFacts depth n env =
270 my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
271 (nest 2 $ vcat $ map pprFact $ ufmToList env))
272 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
273 graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
274 show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
275 pprBlock (Block id t) = nest 2 (pprFact (id, t))
278 \subsection{Backward problems}
280 In a backward problem, we compute \emph{in} facts from \emph{out}
281 facts. The analysis gives us [[exit_in]], [[last_in]], [[middle_in]],
282 and [[first_in]], each of which computes an \emph{in} fact for one
283 kind of node. We provide [[head_in]], which computes the \emph{in}
284 fact for a first node followed by zero or more middle nodes.
286 We don't compute and return the \emph{in} fact for block; instead, we
287 use [[setFact]] to attach that fact to the block's unique~ID.
288 We iterate until no more facts have changed.
290 run_b_anal comp graph =
291 refine_b_anal comp graph (return ())
292 -- for a backward analysis, everything is initially bottom
294 refine_b_anal comp graph initial =
295 run "backward" (bc_name comp) initial set_block_fact () blocks
297 blocks = reverse (postorder_dfs graph)
298 set_block_fact () b@(G.Block id _) =
299 let (h, l) = G.goto_end (G.unzip b) in
301 let block_in = head_in h (last_in comp env l) -- 'in' fact for the block
303 head_in (G.ZHead h m) out = head_in h (bc_middle_in comp out m)
304 head_in (G.ZFirst id) out = bc_first_in comp out id
306 last_in :: BComputation m l i o -> (BlockId -> i) -> G.ZLast l -> o
307 last_in comp env (G.LastOther l) = bc_last_in comp env l
308 last_in comp _ (G.LastExit) = bc_exit_in comp
310 ------ we can now pass those facts elsewhere
311 fold_edge_facts_b f comp graph env z =
312 foldl fold_block_facts z (postorder_dfs graph)
314 fold_block_facts z b =
315 let (h, l) = G.goto_end (G.unzip b)
316 in head_fold h (last_in comp env l) z
317 head_fold (G.ZHead h m) out z = head_fold h (bc_middle_in comp out m) (f out z)
318 head_fold (G.ZFirst id) out z = f (bc_first_in comp out id) (f out z)
320 fold_edge_facts_with_nodes_b fl fm ff comp graph env z =
321 foldl fold_block_facts z (postorder_dfs graph)
323 fold_block_facts z b =
324 let (h, l) = G.goto_end (G.unzip b)
325 in' = last_in comp env l
326 z' = case l of { G.LastExit -> z ; G.LastOther l -> fl l in' z }
327 in head_fold h in' z'
328 head_fold (G.ZHead h m) out z =
329 let a = bc_middle_in comp out m
332 head_fold (G.ZFirst id) out z =
333 let a = bc_first_in comp out id
338 -- | In the general case we solve a graph in the context of a larger subgraph.
339 -- To do this, we need a locally modified computation that allows an
340 -- ``exit fact'' to flow into the exit node.
342 comp_with_exit_b :: BComputation m l i (OptimizationFuel -> DFM f (Answer m l o)) -> o ->
343 BComputation m l i (OptimizationFuel -> DFM f (Answer m l o))
344 comp_with_exit_b comp exit_fact =
345 comp { bc_exit_in = \_fuel -> return $ Dataflow $ exit_fact }
347 -- | Given this function, we can now solve a graph simply by doing a
348 -- backward analysis on the modified computation. Note we have to be
349 -- very careful with 'Rewrite'. Either a rewrite is going to
350 -- participate, in which case we mark the graph rerewritten, or we're
351 -- going to analysis the proposed rewrite and then throw away
352 -- everything but the answer, in which case it's a 'subAnalysis'. A
353 -- Rewrite should always use exactly one of these monadic operations.
356 (DebugNodes m l, Outputable a) =>
357 BPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> DFM a (OptimizationFuel, a)
358 solve_graph_b comp fuel graph exit_fact =
359 general_backward (comp_with_exit_b comp exit_fact) fuel graph
361 -- general_backward :: BPass m l a -> OptimizationFuel -> G.LGraph m l -> DFM a (OptimizationFuel, a)
362 general_backward comp fuel graph =
363 let -- set_block_fact :: OptimizationFuel -> G.Block m l -> DFM a OptimizationFuel
364 set_block_fact fuel b =
365 do { (fuel, block_in) <-
366 let (h, l) = G.goto_end (G.unzip b) in
367 factsEnv >>= \env -> last_in comp env l fuel >>= \x ->
369 Dataflow a -> head_in fuel h a
372 ; (fuel, a) <- subAnalysis' $
373 solve_graph_b_g comp (fuel-1) g bot
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
380 head_in fuel (G.ZHead h m) out =
381 bc_middle_in comp out m fuel >>= \x -> case x of
382 Dataflow a -> head_in fuel h a
384 do { (fuel, a) <- subAnalysis' $ solve_graph_b_g comp (fuel-1) g out
385 ; my_trace "Rewrote middle node"
386 (f4sep [ppr m, text "to", pprGraph g]) $
388 head_in fuel (G.ZFirst id) out =
389 bc_first_in comp out id fuel >>= \x -> case x of
390 Dataflow a -> return (fuel, a)
391 Rewrite g -> do { subAnalysis' $ solve_graph_b_g comp (fuel-1) g out }
394 run "backward" (bc_name comp) (return ()) set_block_fact fuel blocks
395 ; a <- getFact (G.lg_entry graph)
397 ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $
400 blocks = reverse (G.postorder_dfs graph)
401 pprFacts g env a = (ppr a <+> text "with") $$ vcat (pprLgraph g : map pprFact (ufmToList env))
402 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
405 (DebugNodes m l, Outputable a) =>
406 BPass m l a -> OptimizationFuel -> G.Graph m l -> a -> DFM a (OptimizationFuel, a)
407 solve_graph_b_g comp fuel graph exit_fact =
408 do { g <- lgraphOfGraph graph ; solve_graph_b comp fuel g exit_fact }
411 lgraphOfGraph :: G.Graph m l -> DFM f (G.LGraph m l)
413 do id <- freshBlockId "temporary id for dataflow analysis"
414 return $ labelGraph id g
416 labelGraph :: BlockId -> G.Graph m l -> G.LGraph m l
417 labelGraph id (Graph tail blocks) = LGraph id (insertBlock (Block id tail) blocks)
419 -- | We can remove the entry label of an LGraph and remove
420 -- it, leaving a Graph. Notice that this operation is NOT SAFE if a
421 -- block within the LGraph branches to the entry point. It should
422 -- be used only to complement 'lgraphOfGraph' above.
424 remove_entry_label :: LGraph m l -> Graph m l
425 remove_entry_label g =
426 let FGraph e (ZBlock (ZFirst id) tail) others = entry g
427 in ASSERT (id == e) Graph tail others
430 We solve and rewrite in two passes: the first pass iterates to a fixed
431 point to reach a dataflow solution, and the second pass uses that
432 solution to rewrite the graph.
435 key job is done by [[propagate]], which propagates a fact of type~[[a]]
436 between a head and tail.
437 The tail is in final form; the head is still to be rewritten.
440 solve_and_rewrite_b ::
441 (DebugNodes m l, Outputable a) =>
442 BPass m l a -> OptimizationFuel -> LGraph m l -> a -> DFM a (OptimizationFuel, a, LGraph m l)
443 solve_and_rewrite_b_graph ::
444 (DebugNodes m l, Outputable a) =>
445 BPass m l a -> OptimizationFuel -> Graph m l -> a -> DFM a (OptimizationFuel, a, Graph m l)
448 solve_and_rewrite_b comp fuel graph exit_fact =
449 do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1
451 ; (fuel, g) <- -- pass 2
452 my_trace "Solution to graph after pass 1 is" (pprFacts graph facts) $
453 backward_rewrite (comp_with_exit_b comp exit_fact) fuel graph
455 ; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $
456 return (fuel, a, g) }
458 pprFacts g env = vcat (pprLgraph g : map pprFact (ufmToList env))
459 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
460 eid = G.lg_entry graph
461 backward_rewrite comp fuel graph =
462 rewrite_blocks comp fuel emptyBlockEnv $ reverse (G.postorder_dfs graph)
464 -- BPass m l a -> OptimizationFuel ->
465 -- BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel,G.LGraph m l)
466 rewrite_blocks _comp fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
467 rewrite_blocks comp fuel rewritten (b:bs) =
468 let rewrite_next_block fuel =
469 let (h, l) = G.goto_end (G.unzip b) in
470 factsEnv >>= \env -> last_in comp env l fuel >>= \x -> case x of
471 Dataflow a -> propagate fuel h a (G.ZLast l) rewritten
473 do { markGraphRewritten
475 ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g bot
476 ; let G.Graph t new_blocks = g'
477 ; let rewritten' = new_blocks `plusUFM` rewritten
478 ; propagate fuel h a t rewritten' -- continue at entry of g'
480 -- propagate :: OptimizationFuel -- Number of rewrites permitted
481 -- -> G.ZHead m -- Part of current block yet to be rewritten
482 -- -> a -- Fact on edge between head and tail
483 -- -> G.ZTail m l -- Part of current block already rewritten
484 -- -> BlockEnv (Block m l) -- Blocks already rewritten
485 -- -> DFM a (OptimizationFuel, G.LGraph m l)
486 propagate fuel (G.ZHead h m) out tail rewritten =
487 bc_middle_in comp out m fuel >>= \x -> case x of
488 Dataflow a -> propagate fuel h a (G.ZTail m tail) rewritten
490 do { markGraphRewritten
491 ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
492 ; let G.Graph t newblocks = G.splice_tail g' tail
493 ; my_trace "Rewrote middle node"
494 (f4sep [ppr m, text "to", pprGraph g']) $
495 propagate fuel h a t (newblocks `plusUFM` rewritten) }
496 propagate fuel h@(G.ZFirst id) out tail rewritten =
497 bc_first_in comp out id fuel >>= \x -> case x of
499 let b = G.Block id tail in
500 do { checkFactMatch id a
501 ; rewrite_blocks comp fuel (extendBlockEnv rewritten id b) bs }
503 do { markGraphRewritten
504 ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
505 ; let G.Graph t newblocks = G.splice_tail g' tail
506 ; my_trace "Rewrote label " (f4sep [ppr id,text "to",pprGraph g])$
507 propagate fuel h a t (newblocks `plusUFM` rewritten) }
508 in rewrite_next_block fuel
510 {- Note [Rewriting labelled LGraphs]
511 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
512 It's hugely annoying that we get in an LGraph and in order to solve it
513 we have to slap on a new label which we then immediately strip off.
514 But the alternative is to have all the iterative solvers work on
515 Graphs, and then suddenly instead of a single case (ZBlock) every
516 solver has to deal with two cases (ZBlock and ZTail). So until
517 somebody comes along who is smart enough to do this and still leave
518 the code understandable for mortals, it stays as it is.
520 (One part of the solution will be postorder_dfs_from_except.)
523 solve_and_rewrite_b_graph comp fuel graph exit_fact =
524 do g <- lgraphOfGraph graph
525 (fuel, a, g') <- solve_and_rewrite_b comp fuel g exit_fact
526 return (fuel, a, remove_entry_label g')
529 do { fuel <- liftTx txRemaining
531 ; (fuel', _, gc) <- solve_and_rewrite_b comp fuel g bot
532 ; liftTx $ txDecrement (bc_name comp) fuel fuel'
537 This debugging stuff is left over from imperative-land.
538 It might be useful one day if I learn how to cheat the IO monad!
540 debug_b :: (Outputable m, Outputable l, Outputable a) => BPass m l a -> BPass m l a
542 let debug s (f, comp) =
543 let pr = Printf.eprintf in
544 let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
545 let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
546 let wrap f nodestring node fuel =
547 let answer = f node fuel in
548 let () = match answer with
549 | Dataflow a -> fact "in " (nodestring node) a
550 | Rewrite g -> rewr (nodestring node) g in
552 let wrapout f nodestring out node fuel =
553 fact "out" (nodestring node) out;
554 wrap (f out) nodestring node fuel in
555 let last_in = wrap comp.last_in (RS.rtl << G.last_instr) in
556 let middle_in = wrapout comp.middle_in (RS.rtl << G.mid_instr) in
558 let first = function G.Entry -> "<entry>" | G.Label ((u, l), _, _) -> l in
559 wrapout comp.first_in first in
560 f, { comp with last_in = last_in; middle_in = middle_in; first_in = first_in; }
563 anal_b comp = comp { bc_last_in = wrap2 $ bc_last_in comp
564 , bc_exit_in = wrap0 $ bc_exit_in comp
565 , bc_middle_in = wrap2 $ bc_middle_in comp
566 , bc_first_in = wrap2 $ bc_first_in comp }
567 where wrap2 f out node _fuel = return $ Dataflow (f out node)
568 wrap0 fact _fuel = return $ Dataflow fact
570 ignore_transactions_b comp =
571 comp { bc_last_in = wrap2 $ bc_last_in comp
572 , bc_exit_in = wrap0 $ bc_exit_in comp
573 , bc_middle_in = wrap2 $ bc_middle_in comp
574 , bc_first_in = wrap2 $ bc_first_in comp }
575 where wrap2 f out node _fuel = f out node
576 wrap0 fact _fuel = fact
578 answer' :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
579 answer' lift fuel r a =
580 case r of Just gc | fuel > 0 -> do { g <- lift gc; return $ Rewrite g }
581 _ -> return $ Dataflow a
584 :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
585 unlimited_answer' lift _fuel r a =
586 case r of Just gc -> do { g <- lift gc; return $ Rewrite g }
587 _ -> return $ Dataflow a
589 combine_a_t_with :: (OptimizationFuel -> Maybe b -> a -> DFM a (Answer m l a)) ->
590 BAnalysis m l a -> BComputation m l a (Maybe b) ->
592 combine_a_t_with answer anal tx =
593 let last_in env l fuel =
594 answer fuel (bc_last_in tx env l) (bc_last_in anal env l)
595 exit_in fuel = answer fuel (bc_exit_in tx) (bc_exit_in anal)
596 middle_in out m fuel =
597 answer fuel (bc_middle_in tx out m) (bc_middle_in anal out m)
598 first_in out f fuel =
599 answer fuel (bc_first_in tx out f) (bc_first_in anal out f)
600 in BComp { bc_name = concat [bc_name anal, " and ", bc_name tx]
601 , bc_last_in = last_in, bc_middle_in = middle_in
602 , bc_first_in = first_in, bc_exit_in = exit_in }
604 a_t_b = combine_a_t_with (answer' liftUSM)
605 a_ft_b = combine_a_t_with (answer' return)
606 a_ft_b_unlimited = combine_a_t_with (unlimited_answer' return)
609 -- =============== FORWARD ================
611 -- | We don't compute and return the \emph{in} fact for block; instead, we
612 -- use [[P.set]] to attach that fact to the block's unique~ID.
613 -- We iterate until no more facts have changed.
618 my_trace :: String -> SDoc -> a -> a
619 my_trace = if dump_things then pprTrace else \_ _ a -> a
621 run_f_anal comp entry_fact graph = refine_f_anal comp graph set_entry
622 where set_entry = setFact (G.lg_entry graph) entry_fact
624 refine_f_anal comp graph initial =
625 run "forward" (fc_name comp) initial set_successor_facts () blocks
626 where blocks = G.postorder_dfs graph
627 set_successor_facts () (G.Block id t) =
628 let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t
629 forward in' (G.ZLast l) = setEdgeFacts (last_outs comp in' l)
630 _blockname = if id == G.lg_entry graph then "<entry>" else show id
631 in getFact id >>= \a -> forward (fc_first_out comp a id) t
632 setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs
633 setEdgeFact (id, a) = setFact id a
635 last_outs :: FComputation m l i om ol -> i -> G.ZLast l -> ol
636 last_outs comp i (G.LastExit) = fc_exit_outs comp i
637 last_outs comp i (G.LastOther l) = fc_last_outs comp i l
639 -- | In the general case we solve a graph in the context of a larger subgraph.
640 -- To do this, we need a locally modified computation that allows an
641 -- ``exit fact'' to flow out of the exit node. We pass in a fresh BlockId
642 -- to which the exit fact can flow
644 comp_with_exit_f :: FPass m l a -> BlockId -> FPass m l a
645 comp_with_exit_f comp exit_fact_id = comp { fc_exit_outs = exit_outs }
646 where exit_outs in' _fuel = return $ Dataflow $ LastOutFacts [(exit_fact_id, in')]
648 -- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a
649 -- forward analysis on the modified computation.
651 (DebugNodes m l, Outputable a) =>
652 FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
653 DFM a (OptimizationFuel, a, LastOutFacts a)
654 solve_graph_f comp fuel g in_fact =
655 do { exit_fact_id <- freshBlockId "proxy for exit node"
656 ; fuel <- general_forward (comp_with_exit_f comp exit_fact_id) fuel in_fact g
657 ; a <- getFact exit_fact_id
658 ; outs <- lastOutFacts
659 ; forgetFact exit_fact_id -- close space leak
660 ; return (fuel, a, LastOutFacts outs) }
662 -- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel
663 general_forward comp fuel entry_fact graph =
664 let blocks = G.postorder_dfs g
665 is_local id = isJust $ lookupBlockEnv (G.lg_blocks g) id
666 -- set_or_save :: LastOutFacts a -> DFM a ()
667 set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
668 set_or_save_one (id, a) =
669 if is_local id then setFact id a else addLastOutFact (id, a)
670 set_entry = setFact (G.lg_entry graph) entry_fact
672 set_successor_facts fuel b =
673 let set_tail_facts fuel in' (G.ZTail m t) =
674 my_trace "Solving middle node" (ppr m) $
675 fc_middle_out comp in' m fuel >>= \ x -> case x of
676 Dataflow a -> set_tail_facts fuel a t
678 do (fuel, out, last_outs) <-
679 subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
680 set_or_save last_outs
681 set_tail_facts fuel out t
682 set_tail_facts fuel in' (G.ZLast l) =
683 last_outs comp in' l fuel >>= \x -> case x of
684 Dataflow outs -> do { set_or_save outs; return fuel }
686 do (fuel, _, last_outs) <-
687 subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
688 set_or_save last_outs
691 in do idfact <- getFact id
692 infact <- fc_first_out comp idfact id fuel
693 case infact of Dataflow a -> set_tail_facts fuel a t
695 do (fuel, out, last_outs) <- subAnalysis' $
696 solve_graph_f_g comp (fuel-1) g idfact
697 set_or_save last_outs
698 set_tail_facts fuel out t
699 in run "forward" (fc_name comp) set_entry set_successor_facts fuel blocks
702 (DebugNodes m l, Outputable a) =>
703 FPass m l a -> OptimizationFuel -> G.Graph m l -> a ->
704 DFM a (OptimizationFuel, a, LastOutFacts a)
705 solve_graph_f_g comp fuel graph in_fact =
706 do { g <- lgraphOfGraph graph ; solve_graph_f comp fuel g in_fact }
710 We solve and rewrite in two passes: the first pass iterates to a fixed
711 point to reach a dataflow solution, and the second pass uses that
712 solution to rewrite the graph.
714 The key job is done by [[propagate]], which propagates a fact of type~[[a]]
715 between a head and tail.
716 The tail is in final form; the head is still to be rewritten.
718 solve_and_rewrite_f ::
719 (DebugNodes m l, Outputable a) =>
720 FPass m l a -> OptimizationFuel -> LGraph m l -> a ->
721 DFM a (OptimizationFuel, a, LGraph m l)
722 solve_and_rewrite_f comp fuel graph in_fact =
723 do solve_graph_f comp fuel graph in_fact -- pass 1
724 exit_id <- freshBlockId "proxy for exit node"
725 (fuel, g) <- forward_rewrite (comp_with_exit_f comp exit_id) fuel graph in_fact
726 exit_fact <- getFact exit_id
727 return (fuel, exit_fact, g)
729 solve_and_rewrite_f_graph ::
730 (DebugNodes m l, Outputable a) =>
731 FPass m l a -> OptimizationFuel -> Graph m l -> a ->
732 DFM a (OptimizationFuel, a, Graph m l)
733 solve_and_rewrite_f_graph comp fuel graph in_fact =
734 do g <- lgraphOfGraph graph
735 (fuel, a, g') <- solve_and_rewrite_f comp fuel g in_fact
736 return (fuel, a, remove_entry_label g')
739 (DebugNodes m l, Outputable a) =>
740 FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
741 DFM a (OptimizationFuel, G.LGraph m l)
742 forward_rewrite comp fuel graph entry_fact =
743 do setFact eid entry_fact
744 rewrite_blocks fuel emptyBlockEnv (G.postorder_dfs graph)
746 eid = G.lg_entry graph
747 is_local id = isJust $ lookupBlockEnv (G.lg_blocks graph) id
748 -- set_or_save :: LastOutFacts a -> DFM a ()
749 set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
750 set_or_save_one (id, a) =
751 if is_local id then checkFactMatch id a
752 else panic "set fact outside graph during rewriting pass?!"
755 -- OptimizationFuel -> BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel, LGraph m l)
756 rewrite_blocks fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
757 rewrite_blocks fuel rewritten (G.Block id t : bs) =
758 do id_fact <- getFact id
759 first_out <- fc_first_out comp id_fact id fuel
761 Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs
762 Rewrite g -> do { markGraphRewritten
763 ; rewrite_blocks (fuel-1) rewritten
764 (G.postorder_dfs (labelGraph id g) ++ bs) }
765 -- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
766 -- [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l)
767 propagate fuel h in' (G.ZTail m t) rewritten bs =
768 my_trace "Rewriting middle node" (ppr m) $
769 do fc_middle_out comp in' m fuel >>= \x -> case x of
770 Dataflow a -> propagate fuel (G.ZHead h m) a t rewritten bs
772 do markGraphRewritten
773 (fuel, a, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
774 let (blocks, h') = G.splice_head' h g
775 propagate fuel h' a t (blocks `plusUFM` rewritten) bs
776 propagate fuel h in' (G.ZLast l) rewritten bs =
777 do last_outs comp in' l fuel >>= \x -> case x of
780 let b = G.zip (G.ZBlock h (G.ZLast l))
781 rewrite_blocks fuel (G.insertBlock b rewritten) bs
783 do markGraphRewritten
784 (fuel, _, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
785 let g' = G.splice_head_only' h g
786 rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs
788 f_rewrite comp entry_fact g =
789 do { fuel <- liftTx txRemaining
790 ; (fuel', _, gc) <- solve_and_rewrite_f comp fuel g entry_fact
791 ; liftTx $ txDecrement (fc_name comp) fuel fuel'
797 debug_f :: (Outputable m, Outputable l, Outputable a) => FPass m l a -> FPass m l a
799 let debug s (f, comp) =
800 let pr = Printf.eprintf in
801 let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
802 let setter dir node run_sets set =
803 run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in
804 let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
805 let wrap f nodestring wrap_answer in' node fuel =
806 fact "in " (nodestring node) in';
807 wrap_answer (nodestring node) (f in' node fuel)
808 and wrap_fact n answer =
809 let () = match answer with
810 | Dataflow a -> fact "out" n a
811 | Rewrite g -> rewr n g in
813 and wrap_setter n answer =
815 | Dataflow set -> Dataflow (setter "out" n set)
816 | Rewrite g -> (rewr n g; Rewrite g) in
817 let middle_out = wrap comp.middle_out (RS.rtl << G.mid_instr) wrap_fact in
818 let last_outs = wrap comp.last_outs (RS.rtl << G.last_instr) wrap_setter in
819 f, { comp with last_outs = last_outs; middle_out = middle_out; }
822 anal_f comp = comp { fc_first_out = wrap2 $ fc_first_out comp
823 , fc_middle_out = wrap2 $ fc_middle_out comp
824 , fc_last_outs = wrap2 $ fc_last_outs comp
825 , fc_exit_outs = wrap1 $ fc_exit_outs comp
827 where wrap2 f out node _fuel = return $ Dataflow (f out node)
828 wrap1 f fact _fuel = return $ Dataflow (f fact)
832 let answer = answer' liftUSM
833 first_out in' id fuel =
834 answer fuel (fc_first_out tx in' id) (fc_first_out anal in' id)
835 middle_out in' m fuel =
836 answer fuel (fc_middle_out tx in' m) (fc_middle_out anal in' m)
837 last_outs in' l fuel =
838 answer fuel (fc_last_outs tx in' l) (fc_last_outs anal in' l)
839 exit_outs in' fuel = undefined
840 answer fuel (fc_exit_outs tx in') (fc_exit_outs anal in')
841 in FComp { fc_name = concat [fc_name anal, " and ", fc_name tx]
842 , fc_last_outs = last_outs, fc_middle_out = middle_out
843 , fc_first_out = first_out, fc_exit_outs = exit_outs }
846 f4sep :: [SDoc] -> SDoc
848 f4sep (d:ds) = fsep (d : map (nest 4) ds)
850 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
853 do { a <- subAnalysis $
854 do { a <- m; facts <- allFacts
855 ; my_trace "after sub-analysis facts are" (pprFacts facts) $
858 ; my_trace "in parent analysis facts are" (pprFacts facts) $
860 where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
861 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
864 _unused :: FS.FastString