1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
2 {-# OPTIONS -fno-allow-overlapping-instances -fglasgow-exts #-}
3 -- -fglagow-exts for kind signatures
6 ( zdfSolveFrom, zdfRewriteFrom
7 , ForwardTransfers(..), BackwardTransfers(..)
8 , ForwardRewrites(..), BackwardRewrites(..)
9 , ForwardFixedPoint, BackwardFixedPoint
13 , zdfDecoratedGraph -- not yet implemented
23 import qualified ZipCfg as G
35 type PassName = String
36 type Fuel = OptimizationFuel
38 data RewritingDepth = RewriteShallow | RewriteDeep
39 -- When a transformation proposes to rewrite a node,
40 -- you can either ask the system to
41 -- * "shallow": accept the new graph, analyse it without further rewriting
42 -- * "deep": recursively analyse-and-rewrite the new graph
44 -----------------------------
45 -- zdfSolveFrom is a pure analysis with no rewriting
47 class DataflowSolverDirection transfers fixedpt where
48 zdfSolveFrom :: (DebugNodes m l, Outputable a)
49 => BlockEnv a -- Initial facts (unbound == bottom)
51 -> DataflowLattice a -- Lattice
52 -> transfers m l a -- Dataflow transfer functions
53 -> a -- Fact flowing in (at entry or exit)
54 -> Graph m l -- Graph to be analyzed
55 -> fixedpt m l a () -- Answers
57 -- There are exactly two instances: forward and backward
58 instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint
59 where zdfSolveFrom = solve_f
61 instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint
62 where zdfSolveFrom = solve_b
64 data ForwardTransfers middle last a = ForwardTransfers
65 { ft_first_out :: a -> BlockId -> a
66 , ft_middle_out :: a -> middle -> a
67 , ft_last_outs :: a -> last -> LastOutFacts a
68 , ft_exit_out :: a -> a
71 newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
72 -- ^ These are facts flowing out of a last node to the node's successors.
73 -- They are either to be set (if they pertain to the graph currently
74 -- under analysis) or propagated out of a sub-analysis
76 data BackwardTransfers middle last a = BackwardTransfers
77 { bt_first_in :: a -> BlockId -> a
78 , bt_middle_in :: a -> middle -> a
79 , bt_last_in :: (BlockId -> a) -> last -> a
82 data CommonFixedPoint m l fact a = FP
83 { fp_facts :: BlockEnv fact
84 , fp_out :: fact -- entry for backward; exit for forward
85 , fp_changed :: ChangeFlag
86 , fp_dec_graph :: Graph (fact, m) (fact, l)
90 type BackwardFixedPoint = CommonFixedPoint
92 data ForwardFixedPoint m l fact a = FFP
93 { ffp_common :: CommonFixedPoint m l fact a
94 , zdfFpLastOuts :: LastOutFacts fact
97 -----------------------------
98 -- zdfRewriteFrom is an interleaved analysis and transformation
100 class DataflowSolverDirection transfers fixedpt =>
101 DataflowDirection transfers fixedpt rewrites
102 (graph :: * -> * -> *) where
103 zdfRewriteFrom :: (DebugNodes m l, Outputable a)
109 -> rewrites m l a graph
110 -> a -- fact flowing in (at entry or exit)
113 -> FuelMonad (fixedpt m l a (Graph m l))
115 -- There are currently four instances, but there could be more
116 -- forward, backward (instantiates transfers, fixedpt, rewrites)
117 -- Graph, AGraph (instantiates graph)
119 instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites Graph
120 where zdfRewriteFrom = rewrite_f_graph
122 instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites AGraph
123 where zdfRewriteFrom = rewrite_f_agraph
125 instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites Graph
126 where zdfRewriteFrom = rewrite_b_graph
128 instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites AGraph
129 where zdfRewriteFrom = rewrite_b_agraph
131 data ForwardRewrites middle last a g = ForwardRewrites
132 { fr_first :: a -> BlockId -> Maybe (g middle last)
133 , fr_middle :: a -> middle -> Maybe (g middle last)
134 , fr_last :: a -> last -> Maybe (g middle last)
135 , fr_exit :: a -> Maybe (g middle last)
138 data BackwardRewrites middle last a g = BackwardRewrites
139 { br_first :: a -> BlockId -> Maybe (g middle last)
140 , br_middle :: a -> middle -> Maybe (g middle last)
141 , br_last :: (BlockId -> a) -> last -> Maybe (g middle last)
142 , br_exit :: Maybe (g middle last)
145 class FixedPoint fp where
146 zdfFpFacts :: fp m l fact a -> BlockEnv fact
147 zdfFpOutputFact :: fp m l fact a -> fact -- entry for backward; exit for forward
148 zdfGraphChanged :: fp m l fact a -> ChangeFlag
149 zdfDecoratedGraph :: fp m l fact a -> Graph (fact, m) (fact, l)
150 zdfFpContents :: fp m l fact a -> a
151 zdfFpMap :: (a -> b) -> (fp m l fact a -> fp m l fact b)
155 -----------------------------------------------------------
156 -- solve_f: forward, pure
158 solve_f :: (DebugNodes m l, Outputable a)
159 => BlockEnv a -- initial facts (unbound == bottom)
161 -> DataflowLattice a -- lattice
162 -> ForwardTransfers m l a -- dataflow transfer functions
164 -> Graph m l -- graph to be analyzed
165 -> ForwardFixedPoint m l a () -- answers
166 solve_f env name lattice transfers in_fact g =
167 runWithInfiniteFuel $ runDFM panic_us lattice $
168 fwd_pure_anal name env transfers in_fact g
169 where panic_us = panic "pure analysis pulled on a UniqSupply"
171 rewrite_f_graph :: (DebugNodes m l, Outputable a)
176 -> ForwardTransfers m l a
177 -> ForwardRewrites m l a Graph
178 -> a -- fact flowing in (at entry or exit)
181 -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
182 rewrite_f_graph depth start_facts name lattice transfers rewrites in_fact g u =
184 do fuel <- fuelRemaining
185 (fp, fuel') <- forward_rew maybeRewriteWithFuel return depth start_facts name
186 transfers rewrites in_fact g fuel
187 fuelDecrement name fuel fuel'
190 rewrite_f_agraph :: (DebugNodes m l, Outputable a)
195 -> ForwardTransfers m l a
196 -> ForwardRewrites m l a AGraph
197 -> a -- fact flowing in (at entry or exit)
200 -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
201 rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g u =
203 do fuel <- fuelRemaining
204 (fp, fuel') <- forward_rew maybeRewriteWithFuel areturn depth start_facts name
205 transfers rewrites in_fact g fuel
206 fuelDecrement name fuel fuel'
209 areturn :: AGraph m l -> DFM a (Graph m l)
210 areturn g = liftUSM $ graphOfAGraph g
214 graphToLGraph :: LastNode l => Graph m l -> DFM a (LGraph m l)
215 graphToLGraph (Graph (ZLast (LastOther l)) blockenv)
216 | isBranchNode l = return $ LGraph (branchNodeTarget l) blockenv
217 graphToLGraph (Graph tail blockenv) =
218 do id <- freshBlockId "temporary entry label"
219 return $ LGraph id $ insertBlock (Block id tail) blockenv
222 -- | Here we prefer not simply to slap on 'goto eid' because this
223 -- introduces an unnecessary basic block at each rewrite, and we don't
224 -- want to stress out the finite map more than necessary
225 lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
226 lgraphToGraph (LGraph eid blocks) =
227 if flip any (eltsUFM blocks) $ \block -> any (== eid) (succs block) then
228 Graph (ZLast (mkBranchNode eid)) blocks
229 else -- common case: entry is not a branch target
230 let Block _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
231 in Graph entry (delFromUFM blocks eid)
234 class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
236 fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
239 -> ForwardTransfers m l a
242 -> DFM a (ForwardFixedPoint m l a ())
244 fwd_pure_anal name env transfers in_fact g =
245 do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
247 where -- definitiely a case of "I love lazy evaluation"
248 anal_f = forward_sol (\_ _ -> Nothing) panic_return panic_depth
249 panic_rewrites = panic "pure analysis asked for a rewrite function"
250 panic_fuel = panic "pure analysis asked for fuel"
251 panic_return = panic "pure analysis tried to return a rewritten graph"
252 panic_depth = panic "pure analysis asked for a rewrite depth"
254 -----------------------------------------------------------------------
256 -- Here beginneth the super-general functions
258 -- Think of them as (typechecked) macros
259 -- * They are not exported
261 -- * They are called by the specialised wrappers
262 -- above, and always inlined into their callers
264 -- There are four functions, one for each combination of:
268 -- A "solver" produces a (DFM f (f, Fuel)),
269 -- where f is the fact at entry(Bwd)/exit(Fwd)
270 -- and from the DFM you can extract
275 -- A "rewriter" produces a rewritten *Graph* as well
277 -- Both constrain their rewrites by
279 -- b) RewritingDepth: shallow/deep
281 -----------------------------------------------------------------------
284 {-# INLINE forward_sol #-}
287 (DebugNodes m l, LastNode l, Outputable a)
288 => (forall a . Fuel -> Maybe a -> Maybe a)
289 -- Squashes proposed rewrites if there is
290 -- no more fuel; OR if we are doing a pure
291 -- analysis, so totally ignore the rewrite
292 -- ie. For pure-analysis the fn is (\_ _ -> Nothing)
293 -> (g m l -> DFM a (Graph m l))
294 -- Transforms the kind of graph 'g' wanted by the
295 -- client (in ForwardRewrites) to the kind forward_sol likes
296 -> RewritingDepth -- Shallow/deep
298 -> BlockEnv a -- Initial set of facts
299 -> ForwardTransfers m l a
300 -> ForwardRewrites m l a g
304 -> DFM a (ForwardFixedPoint m l a (), Fuel)
305 forward_sol check_maybe return_graph = forw
307 forw :: RewritingDepth
310 -> ForwardTransfers m l a
311 -> ForwardRewrites m l a g
315 -> DFM a (ForwardFixedPoint m l a (), Fuel)
316 forw rewrite name start_facts transfers rewrites =
317 let anal_f :: DFM a b -> a -> Graph m l -> DFM a b
318 anal_f finish in' g =
319 do { fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
321 solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel)
322 solve finish in_fact (Graph entry blockenv) fuel =
323 let blocks = G.postorder_dfs_from blockenv entry
324 set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv)
325 set_successor_facts (Block id tail) fuel =
326 do { idfact <- getFact id
327 ; (last_outs, fuel) <-
328 case check_maybe fuel $ fr_first rewrites idfact id of
329 Nothing -> solve_tail idfact tail fuel
331 do g <- return_graph g
332 (a, fuel) <- subAnalysis' $
334 RewriteDeep -> solve getExitFact idfact g (oneLessFuel fuel)
336 do { a <- anal_f getExitFact idfact g
337 ; return (a, oneLessFuel fuel) }
338 solve_tail a tail fuel
339 ; set_or_save last_outs
342 in do { (last_outs, fuel) <- solve_tail in_fact entry fuel
343 ; set_or_save last_outs
344 ; fuel <- run "forward" name set_successor_facts blocks fuel
349 solve_tail in' (G.ZTail m t) fuel =
350 case check_maybe fuel $ fr_middle rewrites in' m of
351 Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel
353 do { g <- return_graph g
354 ; (a, fuel) <- subAnalysis' $
356 RewriteDeep -> solve getExitFact in' g (oneLessFuel fuel)
357 RewriteShallow -> do { a <- anal_f getExitFact in' g
358 ; return (a, oneLessFuel fuel) }
359 ; solve_tail a t fuel
361 solve_tail in' (G.ZLast l) fuel =
362 case check_maybe fuel $ either_last rewrites in' l of
364 case l of LastOther l -> return (ft_last_outs transfers in' l, fuel)
365 LastExit -> do { setExitFact (ft_exit_out transfers in')
366 ; return (LastOutFacts [], fuel) }
368 do { g <- return_graph g
369 ; (last_outs :: LastOutFacts a, fuel) <- subAnalysis' $
371 RewriteDeep -> solve lastOutFacts in' g (oneLessFuel fuel)
372 RewriteShallow -> do { los <- anal_f lastOutFacts in' g
373 ; return (los, fuel) }
374 ; return (last_outs, fuel)
377 fixed_point in_fact g fuel =
378 do { setAllFacts start_facts
379 ; (a, fuel) <- solve getExitFact in_fact g fuel
380 ; facts <- getAllFacts
381 ; last_outs <- lastOutFacts
382 ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
383 ; let fp = FFP cfp last_outs
387 either_last rewrites in' (LastExit) = fr_exit rewrites in'
388 either_last rewrites in' (LastOther l) = fr_last rewrites in' l
395 mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) =>
396 (BlockId -> Bool) -> LastOutFacts a -> df a ()
397 mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
398 where set_or_save_one (id, a) =
399 if is_local id then setFact id a else addLastOutFact (id, a)
404 {-# INLINE forward_rew #-}
407 (DebugNodes m l, LastNode l, Outputable a)
408 => (forall a . Fuel -> Maybe a -> Maybe a)
409 -> (g m l -> DFM a (Graph m l)) -- option on what to rewrite
413 -> ForwardTransfers m l a
414 -> ForwardRewrites m l a g
418 -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
419 forward_rew check_maybe return_graph = forw
421 solve = forward_sol check_maybe return_graph
422 forw :: RewritingDepth
425 -> ForwardTransfers m l a
426 -> ForwardRewrites m l a g
430 -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
431 forw depth xstart_facts name transfers rewrites in_factx gx fuelx =
432 let rewrite :: BlockEnv a -> DFM a b
433 -> a -> Graph m l -> Fuel
434 -> DFM a (b, Graph m l, Fuel)
435 rewrite start finish in_fact g fuel =
436 let Graph entry blockenv = g
437 blocks = G.postorder_dfs_from blockenv entry
438 in do { solve depth name start transfers rewrites in_fact g fuel
439 ; eid <- freshBlockId "temporary entry id"
440 ; (rewritten, fuel) <-
441 rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
442 ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
444 ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
446 don't_rewrite finish in_fact g fuel =
447 do { solve depth name emptyBlockEnv transfers rewrites in_fact g fuel
449 ; return (a, g, fuel)
452 -> a -> Graph m l -> Fuel
453 -> DFM a (b, Graph m l, Fuel)
454 inner_rew = case depth of RewriteShallow -> don't_rewrite
455 RewriteDeep -> rewrite emptyBlockEnv
457 do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx
458 ; facts <- getAllFacts
459 ; changed <- graphWasRewritten
460 ; last_outs <- lastOutFacts
461 ; let cfp = FP facts a changed (panic "no decoration?!") g
462 ; let fp = FFP cfp last_outs
465 rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
466 -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
467 rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
468 rewrite_blocks (G.Block id t : bs) rewritten fuel =
471 case check_maybe fuel $ fr_first rewrites a id of
472 Nothing -> do { (rewritten, fuel) <- rew_tail h a t rewritten fuel
473 ; rewrite_blocks bs rewritten fuel }
474 Just g -> do { markGraphRewritten
475 ; g <- return_graph g
476 ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
477 ; let (blocks, h) = splice_head' (ZFirst id) g
478 ; (rewritten, fuel) <-
479 rew_tail h outfact t (blocks `plusUFM` rewritten) fuel
480 ; rewrite_blocks bs rewritten fuel }
482 rew_tail head in' (G.ZTail m t) rewritten fuel =
483 my_trace "Rewriting middle node" (ppr m) $
484 case check_maybe fuel $ fr_middle rewrites in' m of
485 Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t
487 Just g -> do { markGraphRewritten
488 ; g <- return_graph g
489 ; (a, g, fuel) <- inner_rew getExitFact in' g fuel
490 ; let (blocks, h) = G.splice_head' head g
491 ; rew_tail h a t (blocks `plusUFM` rewritten) fuel
493 rew_tail h in' (G.ZLast l) rewritten fuel =
494 my_trace "Rewriting last node" (ppr l) $
495 case check_maybe fuel $ either_last rewrites in' l of
496 Nothing -> -- can throw away facts because this is the rewriting phase
497 return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
498 Just g -> do { markGraphRewritten
499 ; g <- return_graph g
500 ; ((), g, fuel) <- inner_rew (return ()) in' g fuel
501 ; let g' = G.splice_head_only' h g
502 ; return (G.lg_blocks g' `plusUFM` rewritten, fuel)
504 either_last rewrites in' (LastExit) = fr_exit rewrites in'
505 either_last rewrites in' (LastOther l) = fr_last rewrites in' l
508 --lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f)
509 lastOutFacts :: DFM f (LastOutFacts f)
510 lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
512 {- ================================================================ -}
514 solve_b :: (DebugNodes m l, Outputable a)
515 => BlockEnv a -- initial facts (unbound == bottom)
517 -> DataflowLattice a -- lattice
518 -> BackwardTransfers m l a -- dataflow transfer functions
520 -> Graph m l -- graph to be analyzed
521 -> BackwardFixedPoint m l a () -- answers
522 solve_b env name lattice transfers exit_fact g =
523 runWithInfiniteFuel $ runDFM panic_us lattice $
524 bwd_pure_anal name env transfers g exit_fact
525 where panic_us = panic "pure analysis pulled on a UniqSupply"
528 rewrite_b_graph :: (DebugNodes m l, Outputable a)
533 -> BackwardTransfers m l a
534 -> BackwardRewrites m l a Graph
535 -> a -- fact flowing in at exit
538 -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
539 rewrite_b_graph depth start_facts name lattice transfers rewrites exit_fact g u =
541 do fuel <- fuelRemaining
542 (fp, fuel') <- backward_rew maybeRewriteWithFuel return depth start_facts name
543 transfers rewrites g exit_fact fuel
544 fuelDecrement name fuel fuel'
547 rewrite_b_agraph :: (DebugNodes m l, Outputable a)
552 -> BackwardTransfers m l a
553 -> BackwardRewrites m l a AGraph
554 -> a -- fact flowing in at exit
557 -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
558 rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g u =
560 do fuel <- fuelRemaining
561 (fp, fuel') <- backward_rew maybeRewriteWithFuel areturn depth start_facts name
562 transfers rewrites g exit_fact fuel
563 fuelDecrement name fuel fuel'
568 {-# INLINE backward_sol #-}
571 (DebugNodes m l, LastNode l, Outputable a)
572 => (forall a . Fuel -> Maybe a -> Maybe a)
573 -> (g m l -> DFM a (Graph m l)) -- option on what to rewrite
577 -> BackwardTransfers m l a
578 -> BackwardRewrites m l a g
582 -> DFM a (BackwardFixedPoint m l a (), Fuel)
583 backward_sol check_maybe return_graph = back
585 back :: RewritingDepth
588 -> BackwardTransfers m l a
589 -> BackwardRewrites m l a g
593 -> DFM a (BackwardFixedPoint m l a (), Fuel)
594 back rewrite name start_facts transfers rewrites =
595 let anal_b :: Graph m l -> a -> DFM a a
597 do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out
598 ; return $ zdfFpOutputFact fp }
600 subsolve :: g m l -> a -> Fuel -> DFM a (a, Fuel)
603 RewriteDeep -> \g a fuel ->
604 subAnalysis' $ do { g <- return_graph g; solve g a (oneLessFuel fuel) }
605 RewriteShallow -> \g a fuel ->
606 subAnalysis' $ do { g <- return_graph g; a <- anal_b g a
607 ; return (a, oneLessFuel fuel) }
609 solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel)
610 solve (Graph entry blockenv) exit_fact fuel =
611 let blocks = reverse $ G.postorder_dfs_from blockenv entry
612 last_in _env (LastExit) = exit_fact
613 last_in env (LastOther l) = bt_last_in transfers env l
614 last_rew _env (LastExit) = br_exit rewrites
615 last_rew env (LastOther l) = br_last rewrites env l
616 set_block_fact block fuel =
617 let (h, l) = G.goto_end (G.unzip block) in
620 case check_maybe fuel $ last_rew env l of
621 Nothing -> return (last_in env l, fuel)
622 Just g -> subsolve g exit_fact fuel
623 ; set_head_fact h a fuel
626 in do { fuel <- run "backward" name set_block_fact blocks fuel
627 ; eid <- freshBlockId "temporary entry id"
628 ; fuel <- set_block_fact (Block eid entry) fuel
634 set_head_fact (G.ZFirst id) a fuel =
635 case check_maybe fuel $ br_first rewrites a id of
636 Nothing -> do { setFact id a; return fuel }
637 Just g -> do { (a, fuel) <- subsolve g a fuel
641 set_head_fact (G.ZHead h m) a fuel =
642 case check_maybe fuel $ br_middle rewrites a m of
643 Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel
644 Just g -> do { (a, fuel) <- subsolve g a fuel
645 ; set_head_fact h a fuel }
647 fixed_point g exit_fact fuel =
648 do { setAllFacts start_facts
649 ; (a, fuel) <- solve g exit_fact fuel
650 ; facts <- getAllFacts
651 ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
656 bwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
659 -> BackwardTransfers m l a
662 -> DFM a (BackwardFixedPoint m l a ())
664 bwd_pure_anal name env transfers g exit_fact =
665 do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel
667 where -- another case of "I love lazy evaluation"
668 anal_b = backward_sol (\_ _ -> Nothing) panic_return panic_depth
669 panic_rewrites = panic "pure analysis asked for a rewrite function"
670 panic_fuel = panic "pure analysis asked for fuel"
671 panic_return = panic "pure analysis tried to return a rewritten graph"
672 panic_depth = panic "pure analysis asked for a rewrite depth"
675 {- ================================================================ -}
677 {-# INLINE backward_rew #-}
680 (DebugNodes m l, LastNode l, Outputable a)
681 => (forall a . Fuel -> Maybe a -> Maybe a)
682 -> (g m l -> DFM a (Graph m l)) -- option on what to rewrite
686 -> BackwardTransfers m l a
687 -> BackwardRewrites m l a g
691 -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
692 backward_rew check_maybe return_graph = back
694 solve = backward_sol check_maybe return_graph
695 back :: RewritingDepth
698 -> BackwardTransfers m l a
699 -> BackwardRewrites m l a g
703 -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
704 back depth xstart_facts name transfers rewrites gx exit_fact fuelx =
705 let rewrite :: BlockEnv a
706 -> Graph m l -> a -> Fuel
707 -> DFM a (a, Graph m l, Fuel)
708 rewrite start g exit_fact fuel =
709 let Graph entry blockenv = g
710 blocks = reverse $ G.postorder_dfs_from blockenv entry
711 in do { solve depth name start transfers rewrites g exit_fact fuel
712 ; eid <- freshBlockId "temporary entry id"
713 ; (rewritten, fuel) <- rewrite_blocks blocks emptyBlockEnv fuel
714 ; (rewritten, fuel) <- rewrite_blocks [Block eid entry] rewritten fuel
716 ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
718 don't_rewrite g exit_fact fuel =
720 solve depth name emptyBlockEnv transfers rewrites g exit_fact fuel
721 ; return (zdfFpOutputFact fp, g, fuel) }
722 inner_rew = case depth of RewriteShallow -> don't_rewrite
723 RewriteDeep -> rewrite emptyBlockEnv
724 inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel)
726 do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx
727 ; facts <- getAllFacts
728 ; changed <- graphWasRewritten
729 ; let fp = FP facts a changed (panic "no decoration?!") g
732 rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
733 -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
734 rewrite_blocks bs rewritten fuel =
736 ; let rew [] r f = return (r, f)
738 do { (r, f) <- rewrite_block env b r f; rew bs r f }
739 ; rew bs rewritten fuel }
740 rewrite_block env b rewritten fuel =
741 let (h, l) = G.goto_end (G.unzip b) in
742 case maybeRewriteWithFuel fuel $ either_last env l of
743 Nothing -> propagate fuel h (last_in env l) (ZLast l) rewritten
745 do { markGraphRewritten
746 ; g <- return_graph g
747 ; (a, g, fuel) <- inner_rew g exit_fact fuel
748 ; let G.Graph t new_blocks = g
749 ; let rewritten' = new_blocks `plusUFM` rewritten
750 ; propagate fuel h a t rewritten' -- continue at entry of g
752 either_last _env (LastExit) = br_exit rewrites
753 either_last env (LastOther l) = br_last rewrites env l
754 last_in _env (LastExit) = exit_fact
755 last_in env (LastOther l) = bt_last_in transfers env l
756 propagate fuel (ZHead h m) a tail rewritten =
757 case maybeRewriteWithFuel fuel $ br_middle rewrites a m of
759 propagate fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
761 do { markGraphRewritten
762 ; g <- return_graph g
763 ; my_trace "Rewrote middle node"
764 (f4sep [ppr m, text "to", pprGraph g]) $
766 ; (a, g, fuel) <- inner_rew g a fuel
767 ; let Graph t newblocks = G.splice_tail g tail
768 ; propagate fuel h a t (newblocks `plusUFM` rewritten) }
769 propagate fuel (ZFirst id) a tail rewritten =
770 case maybeRewriteWithFuel fuel $ br_first rewrites a id of
771 Nothing -> do { checkFactMatch id a
772 ; return (insertBlock (Block id tail) rewritten, fuel) }
774 do { markGraphRewritten
775 ; g <- return_graph g
776 ; my_trace "Rewrote first node"
777 (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
778 ; (a, g, fuel) <- inner_rew g a fuel
779 ; checkFactMatch id a
780 ; let Graph t newblocks = G.splice_tail g tail
781 ; let r = insertBlock (Block id t) (newblocks `plusUFM` rewritten)
785 {- ================================================================ -}
787 instance FixedPoint CommonFixedPoint where
788 zdfFpFacts = fp_facts
789 zdfFpOutputFact = fp_out
790 zdfGraphChanged = fp_changed
791 zdfDecoratedGraph = fp_dec_graph
792 zdfFpContents = fp_contents
793 zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a)
795 instance FixedPoint ForwardFixedPoint where
796 zdfFpFacts = fp_facts . ffp_common
797 zdfFpOutputFact = fp_out . ffp_common
798 zdfGraphChanged = fp_changed . ffp_common
799 zdfDecoratedGraph = fp_dec_graph . ffp_common
800 zdfFpContents = fp_contents . ffp_common
801 zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los
807 my_trace :: String -> SDoc -> a -> a
808 my_trace = if dump_things then pprTrace else \_ _ a -> a
811 -- | Here's a function to run an action on blocks until we reach a fixed point.
812 run :: (Outputable a, DebugNodes m l) =>
813 String -> String -> (Block m l -> b -> DFM a b) -> [Block m l] -> b -> DFM a b
814 run dir name do_block blocks b =
815 do { show_blocks $ iterate (1::Int) }
817 -- N.B. Each iteration starts with the same transaction limit;
818 -- only the rewrites in the final iteration actually count
819 trace_block b block =
820 my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $
823 do { markFactsUnchanged
824 ; b <- foldM trace_block b blocks
825 ; changed <- factsStatus
826 ; facts <- getAllFacts
827 ; let depth = 0 -- was nesting depth
830 NoChange -> unchanged depth $ return b
832 pprFacts depth n facts $
833 if n < 1000 then iterate (n+1)
836 msg n = concat [name, " didn't converge in ", show n, " " , dir,
838 my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
839 ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
840 pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
841 unchanged depth = my_nest depth (text "facts are unchanged")
843 pprFacts depth n env =
844 my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
845 (nest 2 $ vcat $ map pprFact $ ufmToList env))
846 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
847 graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
848 show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
849 pprBlock (Block id t) = nest 2 (pprFact (id, t))
852 f4sep :: [SDoc] -> SDoc
854 f4sep (d:ds) = fsep (d : map (nest 4) ds)
857 subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
860 do { a <- subAnalysis $
861 do { a <- m; facts <- getAllFacts
862 ; my_trace "after sub-analysis facts are" (pprFacts facts) $
864 ; facts <- getAllFacts
865 ; my_trace "in parent analysis facts are" (pprFacts facts) $
867 where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
868 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)