+f_shallow_rewrite anal ftx in_fact g =
+ do { fuel <- fuelRemaining
+ ; solve_shallow_graph_f (return ()) anal ftx in_fact g fuel
+ ; id <- freshBlockId "temporary entry id"
+ ; (blocks, fuel') <-
+ forward_rewrite_gen don't_rewrite anal ftx (ZFirst id) in_fact g fuel
+ ; fuelDecrement (fc_name ftx) fuel fuel'
+ ; return (remove_entry_label (LGraph id blocks))
+ }
+ where don't_rewrite finish g fuel = finish >>= \b -> return (b, g, fuel)
+
+
+shallow_tail_solve_f
+ :: (DebugNodes m l, Outputable a)
+ => DFM a b -- final action and result after solving this tail
+ -> FAnalysis m l a -> FFunctionalTransformation m l a
+ -> (BlockId -> Bool) -- local blocks
+ -> a -> ZTail m l -> OptimizationFuel -> DFM a (b, OptimizationFuel)
+shallow_tail_solve_f finish anal ftx is_local in' (G.ZTail m t) fuel =
+ my_trace "Solving middle node" (ppr m) $
+ case maybeRewriteWithFuel fuel $ fc_middle_out ftx in' m of
+ Just g -> do out <- subAnalysis' $ liftAnal $
+ anal_f_general getExitFact anal in' g
+ shallow_tail_solve_f finish anal ftx is_local out t (oneLessFuel fuel)
+ Nothing -> shallow_tail_solve_f finish anal ftx is_local
+ (fc_middle_out anal in' m) t fuel
+shallow_tail_solve_f finish anal ftx is_local in' (G.ZLast (G.LastOther l)) fuel =
+ case maybeRewriteWithFuel fuel $ fc_last_outs ftx in' l of
+ Just g -> do { last_outs <-
+ subAnalysis' $ liftAnal $ anal_f_general lastOutFacts anal in' g
+ ; set_or_save last_outs
+ ; b <- finish
+ ; return (b, oneLessFuel fuel) }
+ Nothing -> do { set_or_save (fc_last_outs anal in' l)
+ ; b <- finish
+ ; return (b, fuel) }
+ where set_or_save = mk_set_or_save is_local
+shallow_tail_solve_f finish anal ftx _is_local in' (G.ZLast LastExit) fuel =
+ case maybeRewriteWithFuel fuel $ fc_exit_out ftx in' of
+ Just g -> do { a <-
+ subAnalysis' $ liftAnal $ anal_f_general getExitFact anal in' g
+ ; setExitFact a
+ ; b <- finish
+ ; return (b, oneLessFuel fuel) }
+ Nothing -> do { setExitFact $ fc_exit_out anal in'
+ ; b <- finish
+ ; return (b, fuel) }
+
+anal_f_general :: (DebugNodes m l, Outputable a)
+ => DFA a b -> FAnalysis m l a -> a -> Graph m l -> DFA a b
+anal_f_general finish anal in_fact (Graph entry blockenv) =
+ general_forward in_fact
+ where
+ is_local id = isJust $ lookupBlockEnv blockenv id
+ set_or_save = mk_set_or_save is_local
+ anal_tail = gen_tail_anal_f set_or_save anal
+ blocks = G.postorder_dfs_from blockenv entry
+ general_forward in_fact =
+ do { let setup = anal_tail in_fact entry -- sufficient to do once
+ ; let set_successor_facts () (Block id tail) =
+ do { idfact <- getFact id
+ ; anal_tail (fc_first_out anal idfact id) tail }
+ ; run "forward" (fc_name anal) setup set_successor_facts () blocks
+ ; finish
+ }
+
+gen_tail_anal_f :: (Outputable a) =>
+ (LastOutFacts a -> DFA a ()) -> FAnalysis m l a -> a -> ZTail m l -> DFA a ()
+gen_tail_anal_f do_last_outs anal a tail = propagate a tail
+ where propagate a (ZTail m t) = propagate (fc_middle_out anal a m) t
+ propagate a (ZLast LastExit) = setExitFact (fc_exit_out anal a)
+ propagate a (ZLast (LastOther l)) = do_last_outs $ fc_last_outs anal a l
+
+
+solve_shallow_graph_f ::
+ (DebugNodes m l, Outputable a) =>
+ DFM a b ->
+ FAnalysis m l a -> FFunctionalTransformation m l a -> a -> G.Graph m l
+ -> OptimizationFuel -> DFM a (b, OptimizationFuel)
+solve_shallow_graph_f finish anal ftx in_fact (Graph entry blockenv) fuel =
+ do { fuel <- general_forward in_fact fuel
+ ; b <- finish
+ ; return (b, fuel) }
+ where
+ is_local id = isJust $ lookupBlockEnv blockenv id
+ set_or_save = mk_set_or_save is_local
+ solve_tail = shallow_tail_solve_f lastOutFacts anal ftx is_local
+ blocks = G.postorder_dfs_from blockenv entry
+ name = concat [fc_name anal, " and ", fc_name ftx]
+ general_forward in_fact fuel =
+ do { (last_outs, fuel) <- solve_tail in_fact entry fuel
+ ; set_or_save last_outs
+ ; let set_successor_facts fuel (Block id tail) =
+ do { idfact <- getFact id
+ ; (last_outs, fuel) <-
+ case maybeRewriteWithFuel fuel $ fc_first_out ftx idfact id of
+ Nothing -> solve_tail idfact tail fuel
+ Just g ->
+ do outfact <-
+ subAnalysis' $ liftAnal $
+ anal_f_general getExitFact anal idfact g
+ solve_tail outfact tail (oneLessFuel fuel)
+ ; set_or_save last_outs
+ ; return fuel }
+ ; run "forward" name (return ()) set_successor_facts fuel blocks }
+
+mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) =>
+ (BlockId -> Bool) -> LastOutFacts a -> df a ()
+mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
+ where set_or_save_one (id, a) =
+ if is_local id then setFact id a else addLastOutFact (id, a)
+
+lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f)
+lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
+
+
+fwd_rew_tail_gen :: (DebugNodes m l, Outputable a) =>
+ (forall b . DFM a b -> Graph m l -> OptimizationFuel -> DFM a (b, Graph m l, OptimizationFuel)) ->
+ FAnalysis m l a -> FFunctionalTransformation m l a -> ZHead m -> a -> ZTail m l
+ -> BlockEnv (Block m l)
+ -> OptimizationFuel -> DFM a (BlockEnv (Block m l), OptimizationFuel)
+fwd_rew_tail_gen recursive_rewrite anal ftx head in_fact tail rewritten fuel =
+ propagate head in_fact tail rewritten fuel
+ where
+ propagate h in' (G.ZTail m t) rewritten fuel =
+ my_trace "Rewriting middle node" (ppr m) $
+ case maybeRewriteWithFuel fuel $ fc_middle_out ftx in' m of
+ Nothing -> propagate (G.ZHead h m) (fc_middle_out anal in' m) t rewritten fuel
+ Just g -> do markGraphRewritten
+ (a, g, fuel) <- recursive_rewrite getExitFact g fuel
+ let (blocks, h') = G.splice_head' h g
+ propagate h' a t (blocks `plusUFM` rewritten) fuel
+ propagate h in' (G.ZLast l) rewritten fuel =
+ case maybeRewriteWithFuel fuel $ last_rewrite ftx in' l of
+ Nothing -> -- can throw away facts because this is the rewriting phase
+ return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
+ Just g -> do markGraphRewritten
+ ((), g, fuel) <- recursive_rewrite (return ()) g fuel
+ let g' = G.splice_head_only' h g
+ return (G.lg_blocks g' `plusUFM` rewritten, fuel)
+
+forward_rewrite_gen ::
+ (DebugNodes m l, Outputable a) =>
+ (forall b . DFM a b -> Graph m l -> OptimizationFuel -> DFM a (b, Graph m l, OptimizationFuel)) ->
+ FAnalysis m l a -> FFunctionalTransformation m l a -> ZHead m -> a -> Graph m l
+ -> OptimizationFuel -> DFM a (BlockEnv (Block m l), OptimizationFuel)
+forward_rewrite_gen recursive_rewrite anal ftx head a (Graph entry blockenv) fuel =
+ do (rewritten, fuel) <- rewrite_tail head a entry emptyBlockEnv fuel
+ rewrite_blocks (G.postorder_dfs_from blockenv entry) rewritten fuel
+ where
+ -- need to build in some checking for consistency of facts
+ rewrite_tail = fwd_rew_tail_gen recursive_rewrite anal ftx
+ rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
+ rewrite_blocks (G.Block id t : bs) rewritten fuel =
+ do id_fact <- getFact id
+ case maybeRewriteWithFuel fuel $ fc_first_out ftx id_fact id of
+ Nothing -> do { (rewritten, fuel) <-
+ rewrite_tail (ZFirst id) id_fact t rewritten fuel
+ ; rewrite_blocks bs rewritten fuel }
+ Just g -> do { (outfact, g, fuel) <- recursive_rewrite getExitFact g fuel
+ ; let (blocks, h) = splice_head' (ZFirst id) g
+ ; (rewritten, fuel) <-
+ rewrite_tail h outfact t (blocks `plusUFM` rewritten) fuel
+ ; rewrite_blocks bs rewritten fuel }
+
+
+
+
+
+