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 setFact id $ head_in h (last_in comp env l) -- 'in' fact for the block
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
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
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)
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)
319 fold_edge_facts_with_nodes_b fl fm ff comp graph env z =
320 foldl fold_block_facts z (postorder_dfs graph)
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
331 head_fold (G.ZFirst id) out z =
332 let a = bc_first_in comp out id
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.
341 comp_with_exit_b :: BComputation m l i (OptimizationFuel -> DFM f (Answer m l o)) -> o ->
342 BComputation m l i (OptimizationFuel -> DFM f (Answer m l o))
343 comp_with_exit_b comp exit_fact =
344 comp { bc_exit_in = \_fuel -> return $ Dataflow $ exit_fact }
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.
355 (DebugNodes m l, Outputable a) =>
356 BPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> DFM a (OptimizationFuel, a)
357 solve_graph_b comp fuel graph exit_fact =
358 general_backward (comp_with_exit_b comp exit_fact) fuel graph
360 -- general_backward :: BPass m l a -> OptimizationFuel -> G.LGraph m l -> DFM a (OptimizationFuel, a)
361 general_backward comp fuel graph =
362 let -- set_block_fact :: OptimizationFuel -> G.Block m l -> DFM a OptimizationFuel
363 set_block_fact fuel b =
364 do { (fuel, block_in) <-
365 let (h, l) = G.goto_end (G.unzip b) in
366 factsEnv >>= \env -> last_in comp env l fuel >>= \x ->
368 Dataflow a -> head_in fuel h a
371 ; (fuel, a) <- subAnalysis' $
372 solve_graph_b_g comp (fuel-1) g bot
374 ; my_trace "result of" (text (bc_name comp) <+>
375 text "on" <+> ppr (G.blockId b) <+> text "is" <+> ppr block_in) $
376 setFact (G.blockId b) block_in
379 head_in fuel (G.ZHead h m) out =
380 bc_middle_in comp out m fuel >>= \x -> case x of
381 Dataflow a -> head_in fuel h a
383 do { (fuel, a) <- subAnalysis' $ solve_graph_b_g comp (fuel-1) g out
384 ; my_trace "Rewrote middle node"
385 (f4sep [ppr m, text "to", pprGraph g]) $
387 head_in fuel (G.ZFirst id) out =
388 bc_first_in comp out id fuel >>= \x -> case x of
389 Dataflow a -> return (fuel, a)
390 Rewrite g -> do { subAnalysis' $ solve_graph_b_g comp (fuel-1) g out }
393 run "backward" (bc_name comp) (return ()) set_block_fact fuel blocks
394 ; a <- getFact (G.lg_entry graph)
396 ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $
399 blocks = reverse (G.postorder_dfs graph)
400 pprFacts g env a = (ppr a <+> text "with") $$ vcat (pprLgraph g : map pprFact (ufmToList env))
401 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
404 (DebugNodes m l, Outputable a) =>
405 BPass m l a -> OptimizationFuel -> G.Graph m l -> a -> DFM a (OptimizationFuel, a)
406 solve_graph_b_g comp fuel graph exit_fact =
407 do { g <- lgraphOfGraph graph ; solve_graph_b comp fuel g exit_fact }
410 lgraphOfGraph :: G.Graph m l -> DFM f (G.LGraph m l)
412 do id <- freshBlockId "temporary id for dataflow analysis"
413 return $ labelGraph id g
415 labelGraph :: BlockId -> G.Graph m l -> G.LGraph m l
416 labelGraph id (Graph tail blocks) = LGraph id (insertBlock (Block id tail) blocks)
418 -- | We can remove the entry label of an LGraph and remove
419 -- it, leaving a Graph. Notice that this operation is NOT SAFE if a
420 -- block within the LGraph branches to the entry point. It should
421 -- be used only to complement 'lgraphOfGraph' above.
423 remove_entry_label :: LGraph m l -> Graph m l
424 remove_entry_label g =
425 let FGraph e (ZBlock (ZFirst id) tail) others = entry g
426 in ASSERT (id == e) Graph tail others
429 We solve and rewrite in two passes: the first pass iterates to a fixed
430 point to reach a dataflow solution, and the second pass uses that
431 solution to rewrite the graph.
434 key job is done by [[propagate]], which propagates a fact of type~[[a]]
435 between a head and tail.
436 The tail is in final form; the head is still to be rewritten.
439 solve_and_rewrite_b ::
440 (DebugNodes m l, Outputable a) =>
441 BPass m l a -> OptimizationFuel -> LGraph m l -> a -> DFM a (OptimizationFuel, a, LGraph m l)
442 solve_and_rewrite_b_graph ::
443 (DebugNodes m l, Outputable a) =>
444 BPass m l a -> OptimizationFuel -> Graph m l -> a -> DFM a (OptimizationFuel, a, Graph m l)
447 solve_and_rewrite_b comp fuel graph exit_fact =
448 do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1
450 ; (fuel, g) <- -- pass 2
451 my_trace "Solution to graph after pass 1 is" (pprFacts graph facts) $
452 backward_rewrite (comp_with_exit_b comp exit_fact) fuel graph
454 ; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $
455 return (fuel, a, g) }
457 pprFacts g env = vcat (pprLgraph g : map pprFact (ufmToList env))
458 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
459 eid = G.lg_entry graph
460 backward_rewrite comp fuel graph =
461 rewrite_blocks comp fuel emptyBlockEnv $ reverse (G.postorder_dfs graph)
463 -- BPass m l a -> OptimizationFuel ->
464 -- BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel,G.LGraph m l)
465 rewrite_blocks _comp fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
466 rewrite_blocks comp fuel rewritten (b:bs) =
467 let rewrite_next_block fuel =
468 let (h, l) = G.goto_end (G.unzip b) in
469 factsEnv >>= \env -> last_in comp env l fuel >>= \x -> case x of
470 Dataflow a -> propagate fuel h a (G.ZLast l) rewritten
472 do { markGraphRewritten
474 ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g bot
475 ; let G.Graph t new_blocks = g'
476 ; let rewritten' = new_blocks `plusUFM` rewritten
477 ; propagate fuel h a t rewritten' -- continue at entry of g'
479 -- propagate :: OptimizationFuel -- Number of rewrites permitted
480 -- -> G.ZHead m -- Part of current block yet to be rewritten
481 -- -> a -- Fact on edge between head and tail
482 -- -> G.ZTail m l -- Part of current block already rewritten
483 -- -> BlockEnv (Block m l) -- Blocks already rewritten
484 -- -> DFM a (OptimizationFuel, G.LGraph m l)
485 propagate fuel (G.ZHead h m) out tail rewritten =
486 bc_middle_in comp out m fuel >>= \x -> case x of
487 Dataflow a -> propagate fuel h a (G.ZTail m tail) rewritten
489 do { markGraphRewritten
490 ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
491 ; let G.Graph t newblocks = G.splice_tail g' tail
492 ; my_trace "Rewrote middle node"
493 (f4sep [ppr m, text "to", pprGraph g']) $
494 propagate fuel h a t (newblocks `plusUFM` rewritten) }
495 propagate fuel h@(G.ZFirst id) out tail rewritten =
496 bc_first_in comp out id fuel >>= \x -> case x of
498 let b = G.Block id tail in
499 do { checkFactMatch id a
500 ; rewrite_blocks comp fuel (extendBlockEnv rewritten id b) bs }
502 do { markGraphRewritten
503 ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out
504 ; let G.Graph t newblocks = G.splice_tail g' tail
505 ; my_trace "Rewrote label " (f4sep [ppr id,text "to",pprGraph g])$
506 propagate fuel h a t (newblocks `plusUFM` rewritten) }
507 in rewrite_next_block fuel
509 {- Note [Rewriting labelled LGraphs]
510 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
511 It's hugely annoying that we get in an LGraph and in order to solve it
512 we have to slap on a new label which we then immediately strip off.
513 But the alternative is to have all the iterative solvers work on
514 Graphs, and then suddenly instead of a single case (ZBlock) every
515 solver has to deal with two cases (ZBlock and ZTail). So until
516 somebody comes along who is smart enough to do this and still leave
517 the code understandable for mortals, it stays as it is.
519 (One part of the solution will be postorder_dfs_from_except.)
522 solve_and_rewrite_b_graph comp fuel graph exit_fact =
523 do g <- lgraphOfGraph graph
524 (fuel, a, g') <- solve_and_rewrite_b comp fuel g exit_fact
525 return (fuel, a, remove_entry_label g')
528 do { fuel <- liftTx txRemaining
530 ; (fuel', _, gc) <- solve_and_rewrite_b comp fuel g bot
531 ; liftTx $ txDecrement (bc_name comp) fuel fuel'
536 This debugging stuff is left over from imperative-land.
537 It might be useful one day if I learn how to cheat the IO monad!
539 debug_b :: (Outputable m, Outputable l, Outputable a) => BPass m l a -> BPass m l a
541 let debug s (f, comp) =
542 let pr = Printf.eprintf in
543 let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
544 let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
545 let wrap f nodestring node fuel =
546 let answer = f node fuel in
547 let () = match answer with
548 | Dataflow a -> fact "in " (nodestring node) a
549 | Rewrite g -> rewr (nodestring node) g in
551 let wrapout f nodestring out node fuel =
552 fact "out" (nodestring node) out;
553 wrap (f out) nodestring node fuel in
554 let last_in = wrap comp.last_in (RS.rtl << G.last_instr) in
555 let middle_in = wrapout comp.middle_in (RS.rtl << G.mid_instr) in
557 let first = function G.Entry -> "<entry>" | G.Label ((u, l), _, _) -> l in
558 wrapout comp.first_in first in
559 f, { comp with last_in = last_in; middle_in = middle_in; first_in = first_in; }
562 anal_b comp = comp { bc_last_in = wrap2 $ bc_last_in comp
563 , bc_exit_in = wrap0 $ bc_exit_in comp
564 , bc_middle_in = wrap2 $ bc_middle_in comp
565 , bc_first_in = wrap2 $ bc_first_in comp }
566 where wrap2 f out node _fuel = return $ Dataflow (f out node)
567 wrap0 fact _fuel = return $ Dataflow fact
569 ignore_transactions_b comp =
570 comp { bc_last_in = wrap2 $ bc_last_in comp
571 , bc_exit_in = wrap0 $ bc_exit_in comp
572 , bc_middle_in = wrap2 $ bc_middle_in comp
573 , bc_first_in = wrap2 $ bc_first_in comp }
574 where wrap2 f out node _fuel = f out node
575 wrap0 fact _fuel = fact
577 answer' :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
578 answer' lift fuel r a =
579 case r of Just gc | fuel > 0 -> do { g <- lift gc; return $ Rewrite g }
580 _ -> return $ Dataflow a
583 :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
584 unlimited_answer' lift _fuel r a =
585 case r of Just gc -> do { g <- lift gc; return $ Rewrite g }
586 _ -> return $ Dataflow a
588 combine_a_t_with :: (OptimizationFuel -> Maybe b -> a -> DFM a (Answer m l a)) ->
589 BAnalysis m l a -> BComputation m l a (Maybe b) ->
591 combine_a_t_with answer anal tx =
592 let last_in env l fuel =
593 answer fuel (bc_last_in tx env l) (bc_last_in anal env l)
594 exit_in fuel = answer fuel (bc_exit_in tx) (bc_exit_in anal)
595 middle_in out m fuel =
596 answer fuel (bc_middle_in tx out m) (bc_middle_in anal out m)
597 first_in out f fuel =
598 answer fuel (bc_first_in tx out f) (bc_first_in anal out f)
599 in BComp { bc_name = concat [bc_name anal, " and ", bc_name tx]
600 , bc_last_in = last_in, bc_middle_in = middle_in
601 , bc_first_in = first_in, bc_exit_in = exit_in }
603 a_t_b = combine_a_t_with (answer' liftUSM)
604 a_ft_b = combine_a_t_with (answer' return)
605 a_ft_b_unlimited = combine_a_t_with (unlimited_answer' return)
608 -- =============== FORWARD ================
610 -- | We don't compute and return the \emph{in} fact for block; instead, we
611 -- use [[P.set]] to attach that fact to the block's unique~ID.
612 -- We iterate until no more facts have changed.
617 my_trace :: String -> SDoc -> a -> a
618 my_trace = if dump_things then pprTrace else \_ _ a -> a
620 run_f_anal comp entry_fact graph = refine_f_anal comp graph set_entry
621 where set_entry = setFact (G.lg_entry graph) entry_fact
623 refine_f_anal comp graph initial =
624 run "forward" (fc_name comp) initial set_successor_facts () blocks
625 where blocks = G.postorder_dfs graph
626 set_successor_facts () (G.Block id t) =
627 let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t
628 forward in' (G.ZLast l) = setEdgeFacts (last_outs comp in' l)
629 _blockname = if id == G.lg_entry graph then "<entry>" else show id
630 in getFact id >>= \a -> forward (fc_first_out comp a id) t
631 setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs
632 setEdgeFact (id, a) = setFact id a
634 last_outs :: FComputation m l i om ol -> i -> G.ZLast l -> ol
635 last_outs comp i (G.LastExit) = fc_exit_outs comp i
636 last_outs comp i (G.LastOther l) = fc_last_outs comp i l
638 -- | In the general case we solve a graph in the context of a larger subgraph.
639 -- To do this, we need a locally modified computation that allows an
640 -- ``exit fact'' to flow out of the exit node. We pass in a fresh BlockId
641 -- to which the exit fact can flow
643 comp_with_exit_f :: FPass m l a -> BlockId -> FPass m l a
644 comp_with_exit_f comp exit_fact_id = comp { fc_exit_outs = exit_outs }
645 where exit_outs in' _fuel = return $ Dataflow $ LastOutFacts [(exit_fact_id, in')]
647 -- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a
648 -- forward analysis on the modified computation.
650 (DebugNodes m l, Outputable a) =>
651 FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
652 DFM a (OptimizationFuel, a, LastOutFacts a)
653 solve_graph_f comp fuel g in_fact =
654 do { exit_fact_id <- freshBlockId "proxy for exit node"
655 ; fuel <- general_forward (comp_with_exit_f comp exit_fact_id) fuel in_fact g
656 ; a <- getFact exit_fact_id
657 ; outs <- lastOutFacts
658 ; forgetFact exit_fact_id -- close space leak
659 ; return (fuel, a, LastOutFacts outs) }
661 -- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel
662 general_forward comp fuel entry_fact graph =
663 let blocks = G.postorder_dfs g
664 is_local id = isJust $ lookupBlockEnv (G.lg_blocks g) id
665 -- set_or_save :: LastOutFacts a -> DFM a ()
666 set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
667 set_or_save_one (id, a) =
668 if is_local id then setFact id a else addLastOutFact (id, a)
669 set_entry = setFact (G.lg_entry graph) entry_fact
671 set_successor_facts fuel b =
672 let set_tail_facts fuel in' (G.ZTail m t) =
673 my_trace "Solving middle node" (ppr m) $
674 fc_middle_out comp in' m fuel >>= \ x -> case x of
675 Dataflow a -> set_tail_facts fuel a t
677 do (fuel, out, last_outs) <-
678 subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
679 set_or_save last_outs
680 set_tail_facts fuel out t
681 set_tail_facts fuel in' (G.ZLast l) =
682 last_outs comp in' l fuel >>= \x -> case x of
683 Dataflow outs -> do { set_or_save outs; return fuel }
685 do (fuel, _, last_outs) <-
686 subAnalysis' $ solve_graph_f_g comp (fuel-1) g in'
687 set_or_save last_outs
690 in do idfact <- getFact id
691 infact <- fc_first_out comp idfact id fuel
692 case infact of Dataflow a -> set_tail_facts fuel a t
694 do (fuel, out, last_outs) <- subAnalysis' $
695 solve_graph_f_g comp (fuel-1) g idfact
696 set_or_save last_outs
697 set_tail_facts fuel out t
698 in run "forward" (fc_name comp) set_entry set_successor_facts fuel blocks
701 (DebugNodes m l, Outputable a) =>
702 FPass m l a -> OptimizationFuel -> G.Graph m l -> a ->
703 DFM a (OptimizationFuel, a, LastOutFacts a)
704 solve_graph_f_g comp fuel graph in_fact =
705 do { g <- lgraphOfGraph graph ; solve_graph_f comp fuel g in_fact }
709 We solve and rewrite in two passes: the first pass iterates to a fixed
710 point to reach a dataflow solution, and the second pass uses that
711 solution to rewrite the graph.
713 The key job is done by [[propagate]], which propagates a fact of type~[[a]]
714 between a head and tail.
715 The tail is in final form; the head is still to be rewritten.
717 solve_and_rewrite_f ::
718 (DebugNodes m l, Outputable a) =>
719 FPass m l a -> OptimizationFuel -> LGraph m l -> a ->
720 DFM a (OptimizationFuel, a, LGraph m l)
721 solve_and_rewrite_f comp fuel graph in_fact =
722 do solve_graph_f comp fuel graph in_fact -- pass 1
723 exit_id <- freshBlockId "proxy for exit node"
724 (fuel, g) <- forward_rewrite (comp_with_exit_f comp exit_id) fuel graph in_fact
725 exit_fact <- getFact exit_id
726 return (fuel, exit_fact, g)
728 solve_and_rewrite_f_graph ::
729 (DebugNodes m l, Outputable a) =>
730 FPass m l a -> OptimizationFuel -> Graph m l -> a ->
731 DFM a (OptimizationFuel, a, Graph m l)
732 solve_and_rewrite_f_graph comp fuel graph in_fact =
733 do g <- lgraphOfGraph graph
734 (fuel, a, g') <- solve_and_rewrite_f comp fuel g in_fact
735 return (fuel, a, remove_entry_label g')
738 (DebugNodes m l, Outputable a) =>
739 FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
740 DFM a (OptimizationFuel, G.LGraph m l)
741 forward_rewrite comp fuel graph entry_fact =
742 do setFact eid entry_fact
743 rewrite_blocks fuel emptyBlockEnv (G.postorder_dfs graph)
745 eid = G.lg_entry graph
746 is_local id = isJust $ lookupBlockEnv (G.lg_blocks graph) id
747 -- set_or_save :: LastOutFacts a -> DFM a ()
748 set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
749 set_or_save_one (id, a) =
750 if is_local id then checkFactMatch id a
751 else panic "set fact outside graph during rewriting pass?!"
754 -- OptimizationFuel -> BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel, LGraph m l)
755 rewrite_blocks fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
756 rewrite_blocks fuel rewritten (G.Block id t : bs) =
757 do id_fact <- getFact id
758 first_out <- fc_first_out comp id_fact id fuel
760 Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs
761 Rewrite g -> do { markGraphRewritten
762 ; rewrite_blocks (fuel-1) rewritten
763 (G.postorder_dfs (labelGraph id g) ++ bs) }
764 -- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
765 -- [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l)
766 propagate fuel h in' (G.ZTail m t) rewritten bs =
767 my_trace "Rewriting middle node" (ppr m) $
768 do fc_middle_out comp in' m fuel >>= \x -> case x of
769 Dataflow a -> propagate fuel (G.ZHead h m) a t rewritten bs
771 do markGraphRewritten
772 (fuel, a, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
773 let (blocks, h') = G.splice_head' h g
774 propagate fuel h' a t (blocks `plusUFM` rewritten) bs
775 propagate fuel h in' (G.ZLast l) rewritten bs =
776 do last_outs comp in' l fuel >>= \x -> case x of
779 let b = G.zip (G.ZBlock h (G.ZLast l))
780 rewrite_blocks fuel (G.insertBlock b rewritten) bs
782 do markGraphRewritten
783 (fuel, _, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in'
784 let g' = G.splice_head_only' h g
785 rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs
787 f_rewrite comp entry_fact g =
788 do { fuel <- liftTx txRemaining
789 ; (fuel', _, gc) <- solve_and_rewrite_f comp fuel g entry_fact
790 ; liftTx $ txDecrement (fc_name comp) fuel fuel'
796 debug_f :: (Outputable m, Outputable l, Outputable a) => FPass m l a -> FPass m l a
798 let debug s (f, comp) =
799 let pr = Printf.eprintf in
800 let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
801 let setter dir node run_sets set =
802 run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in
803 let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
804 let wrap f nodestring wrap_answer in' node fuel =
805 fact "in " (nodestring node) in';
806 wrap_answer (nodestring node) (f in' node fuel)
807 and wrap_fact n answer =
808 let () = match answer with
809 | Dataflow a -> fact "out" n a
810 | Rewrite g -> rewr n g in
812 and wrap_setter n answer =
814 | Dataflow set -> Dataflow (setter "out" n set)
815 | Rewrite g -> (rewr n g; Rewrite g) in
816 let middle_out = wrap comp.middle_out (RS.rtl << G.mid_instr) wrap_fact in
817 let last_outs = wrap comp.last_outs (RS.rtl << G.last_instr) wrap_setter in
818 f, { comp with last_outs = last_outs; middle_out = middle_out; }
821 anal_f comp = comp { fc_first_out = wrap2 $ fc_first_out comp
822 , fc_middle_out = wrap2 $ fc_middle_out comp
823 , fc_last_outs = wrap2 $ fc_last_outs comp
824 , fc_exit_outs = wrap1 $ fc_exit_outs comp
826 where wrap2 f out node _fuel = return $ Dataflow (f out node)
827 wrap1 f fact _fuel = return $ Dataflow (f fact)
831 let answer = answer' liftUSM
832 first_out in' id fuel =
833 answer fuel (fc_first_out tx in' id) (fc_first_out anal in' id)
834 middle_out in' m fuel =
835 answer fuel (fc_middle_out tx in' m) (fc_middle_out anal in' m)
836 last_outs in' l fuel =
837 answer fuel (fc_last_outs tx in' l) (fc_last_outs anal in' l)
838 exit_outs in' fuel = undefined
839 answer fuel (fc_exit_outs tx in') (fc_exit_outs anal in')
840 in FComp { fc_name = concat [fc_name anal, " and ", fc_name tx]
841 , fc_last_outs = last_outs, fc_middle_out = middle_out
842 , fc_first_out = first_out, fc_exit_outs = exit_outs }
845 f4sep :: [SDoc] -> SDoc
847 f4sep (d:ds) = fsep (d : map (nest 4) ds)
849 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
852 do { a <- subAnalysis $
853 do { a <- m; facts <- allFacts
854 ; my_trace "after sub-analysis facts are" (pprFacts facts) $
857 ; my_trace "in parent analysis facts are" (pprFacts facts) $
859 where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
860 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
863 _unused :: FS.FastString