X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipDataflow.hs;h=97b146c0ff609fde090b5580fa0ad9019a050e74;hb=d7b36bbbcd56ee14656223d02e32f5a1f52ea17b;hp=6c9a4b01e96c057b7edebdaf261396b36cb3a438;hpb=21a2d1db975dc0fa3fd0aff82f04a539b64e7103;p=ghc-hetmet.git diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index 6c9a4b0..97b146c 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -1,9 +1,10 @@ {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} -{-# OPTIONS -fno-allow-overlapping-instances -fglasgow-exts #-} +{-# OPTIONS -fglasgow-exts #-} -- -fglagow-exts for kind signatures module ZipDataflow - ( zdfSolveFrom, zdfRewriteFrom + ( DebugNodes(), RewritingDepth(..), LastOutFacts(..) + , zdfSolveFrom, zdfRewriteFrom , ForwardTransfers(..), BackwardTransfers(..) , ForwardRewrites(..), BackwardRewrites(..) , ForwardFixedPoint, BackwardFixedPoint @@ -16,6 +17,7 @@ module ZipDataflow ) where +import BlockId import CmmTx import DFMonad import MkZipCfg @@ -26,7 +28,6 @@ import Maybes import Outputable import Panic import UniqFM -import UniqSupply import Control.Monad import Maybe @@ -149,21 +150,21 @@ newtype LastOutFacts a = LastOutFacts [(BlockId, a)] -- but it might be worth simplifying this module by replacing this type -- parameter with AGraph everywhere (SLPJ 19 May 2008). -data BackwardRewrites middle last a g = BackwardRewrites - { br_first :: a -> BlockId -> Maybe (g middle last) - , br_middle :: a -> middle -> Maybe (g middle last) - , br_last :: (BlockId -> a) -> last -> Maybe (g middle last) - , br_exit :: Maybe (g middle last) +data BackwardRewrites middle last a = BackwardRewrites + { br_first :: a -> BlockId -> Maybe (AGraph middle last) + , br_middle :: a -> middle -> Maybe (AGraph middle last) + , br_last :: (BlockId -> a) -> last -> Maybe (AGraph middle last) + , br_exit :: Maybe (AGraph middle last) } -- | A forward rewrite takes the same inputs as a forward transfer, -- but instead of producing a fact, it produces a replacement graph or Nothing. -data ForwardRewrites middle last a g = ForwardRewrites - { fr_first :: a -> BlockId -> Maybe (g middle last) - , fr_middle :: a -> middle -> Maybe (g middle last) - , fr_last :: a -> last -> Maybe (g middle last) - , fr_exit :: a -> Maybe (g middle last) +data ForwardRewrites middle last a = ForwardRewrites + { fr_first :: a -> BlockId -> Maybe (AGraph middle last) + , fr_middle :: a -> middle -> Maybe (AGraph middle last) + , fr_last :: a -> last -> Maybe (AGraph middle last) + , fr_exit :: a -> Maybe (AGraph middle last) } {- ===================== FIXED POINTS =================== -} @@ -231,7 +232,7 @@ data ForwardFixedPoint m l fact a = FFP type PassName = String --- | zdfSolveFrom is an overloaded name that resolves to a pure +-- | 'zdfSolveFrom' is an overloaded name that resolves to a pure -- analysis with no rewriting. It has only two instances: forward and -- backward. Since it needs no rewrites, the type parameters of the -- class are transfer functions and the fixed point. @@ -251,17 +252,17 @@ type PassName = String -- -- The intent of the rest of the type signature should be obvious. -- If not, place a skype call to norman-ramsey or complain bitterly --- to norman-ramsey@acm.org. +-- to . class DataflowSolverDirection transfers fixedpt where zdfSolveFrom :: (DebugNodes m l, Outputable a) - => BlockEnv a -- Initial facts (unbound == bottom) + => BlockEnv a -- ^ Initial facts (unbound == bottom) -> PassName - -> DataflowLattice a -- Lattice - -> transfers m l a -- Dataflow transfer functions - -> a -- Fact flowing in (at entry or exit) - -> Graph m l -- Graph to be analyzed - -> fixedpt m l a () -- Answers + -> DataflowLattice a -- ^ Lattice + -> transfers m l a -- ^ Dataflow transfer functions + -> a -- ^ Fact flowing in (at entry or exit) + -> Graph m l -- ^ Graph to be analyzed + -> FuelMonad (fixedpt m l a ()) -- ^ Answers -- There are exactly two instances: forward and backward instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint @@ -294,18 +295,16 @@ instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint -- that it doesn't make us sick to look at the types. class DataflowSolverDirection transfers fixedpt => - DataflowDirection transfers fixedpt rewrites - (graph :: * -> * -> *) where + DataflowDirection transfers fixedpt rewrites where zdfRewriteFrom :: (DebugNodes m l, Outputable a) => RewritingDepth -- whether to rewrite a rewritten graph -> BlockEnv a -- initial facts (unbound == botton) -> PassName -> DataflowLattice a -> transfers m l a - -> rewrites m l a graph + -> rewrites m l a -> a -- fact flowing in (at entry or exit) -> Graph m l - -> UniqSupply -> FuelMonad (fixedpt m l a (Graph m l)) data RewritingDepth = RewriteShallow | RewriteDeep @@ -319,16 +318,10 @@ data RewritingDepth = RewriteShallow | RewriteDeep -- forward, backward (instantiates transfers, fixedpt, rewrites) -- Graph, AGraph (instantiates graph) -instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites Graph - where zdfRewriteFrom = rewrite_f_graph - -instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites AGraph +instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites where zdfRewriteFrom = rewrite_f_agraph -instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites Graph - where zdfRewriteFrom = rewrite_b_graph - -instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites AGraph +instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites where zdfRewriteFrom = rewrite_b_agraph @@ -345,52 +338,30 @@ solve_f :: (DebugNodes m l, Outputable a) -> ForwardTransfers m l a -- dataflow transfer functions -> a -> Graph m l -- graph to be analyzed - -> ForwardFixedPoint m l a () -- answers + -> FuelMonad (ForwardFixedPoint m l a ()) -- answers solve_f env name lattice transfers in_fact g = - runWithInfiniteFuel $ runDFM panic_us lattice $ - fwd_pure_anal name env transfers in_fact g - where panic_us = panic "pure analysis pulled on a UniqSupply" + runDFM lattice $ fwd_pure_anal name env transfers in_fact g -rewrite_f_graph :: (DebugNodes m l, Outputable a) - => RewritingDepth - -> BlockEnv a - -> PassName - -> DataflowLattice a - -> ForwardTransfers m l a - -> ForwardRewrites m l a Graph - -> a -- fact flowing in (at entry or exit) - -> Graph m l - -> UniqSupply - -> FuelMonad (ForwardFixedPoint m l a (Graph m l)) -rewrite_f_graph depth start_facts name lattice transfers rewrites in_fact g u = - runDFM u lattice $ - do fuel <- fuelRemaining - (fp, fuel') <- forward_rew maybeRewriteWithFuel return depth start_facts name - transfers rewrites in_fact g fuel - fuelDecrement name fuel fuel' - return fp - rewrite_f_agraph :: (DebugNodes m l, Outputable a) => RewritingDepth -> BlockEnv a -> PassName -> DataflowLattice a -> ForwardTransfers m l a - -> ForwardRewrites m l a AGraph + -> ForwardRewrites m l a -> a -- fact flowing in (at entry or exit) -> Graph m l - -> UniqSupply -> FuelMonad (ForwardFixedPoint m l a (Graph m l)) -rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g u = - runDFM u lattice $ +rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g = + runDFM lattice $ do fuel <- fuelRemaining - (fp, fuel') <- forward_rew maybeRewriteWithFuel areturn depth start_facts name + (fp, fuel') <- forward_rew maybeRewriteWithFuel depth start_facts name transfers rewrites in_fact g fuel fuelDecrement name fuel fuel' return fp areturn :: AGraph m l -> DFM a (Graph m l) -areturn g = liftUSM $ graphOfAGraph g +areturn g = liftToDFM $ liftUniq $ graphOfAGraph g {- @@ -428,10 +399,9 @@ fwd_pure_anal name env transfers in_fact g = do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel return fp where -- definitiely a case of "I love lazy evaluation" - anal_f = forward_sol (\_ _ -> Nothing) panic_return panic_depth + anal_f = forward_sol (\_ _ -> Nothing) panic_depth panic_rewrites = panic "pure analysis asked for a rewrite function" panic_fuel = panic "pure analysis asked for fuel" - panic_return = panic "pure analysis tried to return a rewritten graph" panic_depth = panic "pure analysis asked for a rewrite depth" ----------------------------------------------------------------------- @@ -467,32 +437,29 @@ type Fuel = OptimizationFuel {-# INLINE forward_sol #-} forward_sol - :: forall m l g a . + :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) => (forall a . Fuel -> Maybe a -> Maybe a) -- Squashes proposed rewrites if there is -- no more fuel; OR if we are doing a pure -- analysis, so totally ignore the rewrite -- ie. For pure-analysis the fn is (\_ _ -> Nothing) - -> (g m l -> DFM a (Graph m l)) - -- Transforms the kind of graph 'g' wanted by the - -- client (in ForwardRewrites) to the kind forward_sol likes -> RewritingDepth -- Shallow/deep -> PassName -> BlockEnv a -- Initial set of facts -> ForwardTransfers m l a - -> ForwardRewrites m l a g + -> ForwardRewrites m l a -> a -- Entry fact -> Graph m l -> Fuel -> DFM a (ForwardFixedPoint m l a (), Fuel) -forward_sol check_maybe return_graph = forw +forward_sol check_maybe = forw where forw :: RewritingDepth -> PassName -> BlockEnv a -> ForwardTransfers m l a - -> ForwardRewrites m l a g + -> ForwardRewrites m l a -> a -> Graph m l -> Fuel @@ -510,9 +477,9 @@ forward_sol check_maybe return_graph = forw do { idfact <- getFact id ; (last_outs, fuel) <- case check_maybe fuel $ fr_first rewrites idfact id of - Nothing -> solve_tail idfact tail fuel + Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel Just g -> - do g <- return_graph g + do g <- areturn g (a, fuel) <- subAnalysis' $ case rewrite of RewriteDeep -> solve getExitFact idfact g (oneLessFuel fuel) @@ -534,7 +501,7 @@ forward_sol check_maybe return_graph = forw case check_maybe fuel $ fr_middle rewrites in' m of Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel Just g -> - do { g <- return_graph g + do { g <- areturn g ; (a, fuel) <- subAnalysis' $ case rewrite of RewriteDeep -> solve getExitFact in' g (oneLessFuel fuel) @@ -549,7 +516,7 @@ forward_sol check_maybe return_graph = forw LastExit -> do { setExitFact (ft_exit_out transfers in') ; return (LastOutFacts [], fuel) } Just g -> - do { g <- return_graph g + do { g <- areturn g ; (last_outs :: LastOutFacts a, fuel) <- subAnalysis' $ case rewrite of RewriteDeep -> solve lastOutFacts in' g (oneLessFuel fuel) @@ -587,27 +554,26 @@ mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l {-# INLINE forward_rew #-} forward_rew - :: forall m l g a . + :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) => (forall a . Fuel -> Maybe a -> Maybe a) - -> (g m l -> DFM a (Graph m l)) -- option on what to rewrite -> RewritingDepth -> BlockEnv a -> PassName -> ForwardTransfers m l a - -> ForwardRewrites m l a g + -> ForwardRewrites m l a -> a -> Graph m l -> Fuel -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel) -forward_rew check_maybe return_graph = forw +forward_rew check_maybe = forw where - solve = forward_sol check_maybe return_graph + solve = forward_sol check_maybe forw :: RewritingDepth -> BlockEnv a -> PassName -> ForwardTransfers m l a - -> ForwardRewrites m l a g + -> ForwardRewrites m l a -> a -> Graph m l -> Fuel @@ -627,16 +593,15 @@ forward_rew check_maybe return_graph = forw ; a <- finish ; return (a, lgraphToGraph (LGraph eid rewritten), fuel) } - don't_rewrite finish in_fact g fuel = - do { solve depth name emptyBlockEnv transfers rewrites in_fact g fuel + don't_rewrite facts finish in_fact g fuel = + do { solve depth name facts transfers rewrites in_fact g fuel ; a <- finish ; return (a, g, fuel) } - inner_rew :: DFM a b - -> a -> Graph m l -> Fuel - -> DFM a (b, Graph m l, Fuel) - inner_rew = case depth of RewriteShallow -> don't_rewrite - RewriteDeep -> rewrite emptyBlockEnv + inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel) + inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu + where inner_rew' = case depth of RewriteShallow -> don't_rewrite + RewriteDeep -> rewrite fixed_pt_and_fuel = do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx ; facts <- getAllFacts @@ -653,10 +618,12 @@ forward_rew check_maybe return_graph = forw do let h = ZFirst id a <- getFact id case check_maybe fuel $ fr_first rewrites a id of - Nothing -> do { (rewritten, fuel) <- rew_tail h a t rewritten fuel + Nothing -> do { (rewritten, fuel) <- + rew_tail h (ft_first_out transfers a id) + t rewritten fuel ; rewrite_blocks bs rewritten fuel } Just g -> do { markGraphRewritten - ; g <- return_graph g + ; g <- areturn g ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel ; let (blocks, h) = splice_head' (ZFirst id) g ; (rewritten, fuel) <- @@ -669,7 +636,7 @@ forward_rew check_maybe return_graph = forw Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t rewritten fuel Just g -> do { markGraphRewritten - ; g <- return_graph g + ; g <- areturn g ; (a, g, fuel) <- inner_rew getExitFact in' g fuel ; let (blocks, h) = G.splice_head' head g ; rew_tail h a t (blocks `plusUFM` rewritten) fuel @@ -677,19 +644,22 @@ forward_rew check_maybe return_graph = forw rew_tail h in' (G.ZLast l) rewritten fuel = my_trace "Rewriting last node" (ppr l) $ case check_maybe fuel $ either_last rewrites in' l of - Nothing -> -- can throw away facts because this is the rewriting phase - return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel) + Nothing -> do check_facts in' l + return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel) Just g -> do { markGraphRewritten - ; g <- return_graph g + ; g <- areturn g ; ((), g, fuel) <- inner_rew (return ()) in' g fuel ; let g' = G.splice_head_only' h g ; return (G.lg_blocks g' `plusUFM` rewritten, fuel) } either_last rewrites in' (LastExit) = fr_exit rewrites in' either_last rewrites in' (LastOther l) = fr_last rewrites in' l + check_facts in' (LastOther l) = + let LastOutFacts last_outs = ft_last_outs transfers in' l + in mapM (uncurry checkFactMatch) last_outs + check_facts _ LastExit = return [] in fixed_pt_and_fuel ---lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f) lastOutFacts :: DFM f (LastOutFacts f) lastOutFacts = bareLastOutFacts >>= return . LastOutFacts @@ -702,47 +672,25 @@ solve_b :: (DebugNodes m l, Outputable a) -> BackwardTransfers m l a -- dataflow transfer functions -> a -- exit fact -> Graph m l -- graph to be analyzed - -> BackwardFixedPoint m l a () -- answers + -> FuelMonad (BackwardFixedPoint m l a ()) -- answers solve_b env name lattice transfers exit_fact g = - runWithInfiniteFuel $ runDFM panic_us lattice $ - bwd_pure_anal name env transfers g exit_fact - where panic_us = panic "pure analysis pulled on a UniqSupply" + runDFM lattice $ bwd_pure_anal name env transfers g exit_fact -rewrite_b_graph :: (DebugNodes m l, Outputable a) - => RewritingDepth - -> BlockEnv a - -> PassName - -> DataflowLattice a - -> BackwardTransfers m l a - -> BackwardRewrites m l a Graph - -> a -- fact flowing in at exit - -> Graph m l - -> UniqSupply - -> FuelMonad (BackwardFixedPoint m l a (Graph m l)) -rewrite_b_graph depth start_facts name lattice transfers rewrites exit_fact g u = - runDFM u lattice $ - do fuel <- fuelRemaining - (fp, fuel') <- backward_rew maybeRewriteWithFuel return depth start_facts name - transfers rewrites g exit_fact fuel - fuelDecrement name fuel fuel' - return fp - rewrite_b_agraph :: (DebugNodes m l, Outputable a) => RewritingDepth -> BlockEnv a -> PassName -> DataflowLattice a -> BackwardTransfers m l a - -> BackwardRewrites m l a AGraph + -> BackwardRewrites m l a -> a -- fact flowing in at exit -> Graph m l - -> UniqSupply -> FuelMonad (BackwardFixedPoint m l a (Graph m l)) -rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g u = - runDFM u lattice $ +rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g = + runDFM lattice $ do fuel <- fuelRemaining - (fp, fuel') <- backward_rew maybeRewriteWithFuel areturn depth start_facts name + (fp, fuel') <- backward_rew maybeRewriteWithFuel depth start_facts name transfers rewrites g exit_fact fuel fuelDecrement name fuel fuel' return fp @@ -751,26 +699,25 @@ rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g u {-# INLINE backward_sol #-} backward_sol - :: forall m l g a . + :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) => (forall a . Fuel -> Maybe a -> Maybe a) - -> (g m l -> DFM a (Graph m l)) -- option on what to rewrite -> RewritingDepth -> PassName -> BlockEnv a -> BackwardTransfers m l a - -> BackwardRewrites m l a g + -> BackwardRewrites m l a -> Graph m l -> a -> Fuel -> DFM a (BackwardFixedPoint m l a (), Fuel) -backward_sol check_maybe return_graph = back +backward_sol check_maybe = back where back :: RewritingDepth -> PassName -> BlockEnv a -> BackwardTransfers m l a - -> BackwardRewrites m l a g + -> BackwardRewrites m l a -> Graph m l -> a -> Fuel @@ -781,13 +728,13 @@ backward_sol check_maybe return_graph = back do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out ; return $ zdfFpOutputFact fp } - subsolve :: g m l -> a -> Fuel -> DFM a (a, Fuel) + subsolve :: AGraph m l -> a -> Fuel -> DFM a (a, Fuel) subsolve = case rewrite of RewriteDeep -> \g a fuel -> - subAnalysis' $ do { g <- return_graph g; solve g a (oneLessFuel fuel) } + subAnalysis' $ do { g <- areturn g; solve g a (oneLessFuel fuel) } RewriteShallow -> \g a fuel -> - subAnalysis' $ do { g <- return_graph g; a <- anal_b g a + subAnalysis' $ do { g <- areturn g; a <- anal_b g a ; return (a, oneLessFuel fuel) } solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel) @@ -817,7 +764,9 @@ backward_sol check_maybe return_graph = back set_head_fact (G.ZFirst id) a fuel = case check_maybe fuel $ br_first rewrites a id of - Nothing -> do { setFact id a; return fuel } + Nothing -> do { my_trace "set_head_fact" (ppr id) $ + setFact id $ bt_first_in transfers a id + ; return fuel } Just g -> do { (a, fuel) <- subsolve g a fuel ; setFact id a ; return fuel @@ -849,10 +798,9 @@ bwd_pure_anal name env transfers g exit_fact = do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel return fp where -- another case of "I love lazy evaluation" - anal_b = backward_sol (\_ _ -> Nothing) panic_return panic_depth + anal_b = backward_sol (\_ _ -> Nothing) panic_depth panic_rewrites = panic "pure analysis asked for a rewrite function" panic_fuel = panic "pure analysis asked for fuel" - panic_return = panic "pure analysis tried to return a rewritten graph" panic_depth = panic "pure analysis asked for a rewrite depth" @@ -860,27 +808,26 @@ bwd_pure_anal name env transfers g exit_fact = {-# INLINE backward_rew #-} backward_rew - :: forall m l g a . + :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) => (forall a . Fuel -> Maybe a -> Maybe a) - -> (g m l -> DFM a (Graph m l)) -- option on what to rewrite -> RewritingDepth -> BlockEnv a -> PassName -> BackwardTransfers m l a - -> BackwardRewrites m l a g + -> BackwardRewrites m l a -> Graph m l -> a -> Fuel -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel) -backward_rew check_maybe return_graph = back +backward_rew check_maybe = back where - solve = backward_sol check_maybe return_graph + solve = backward_sol check_maybe back :: RewritingDepth -> BlockEnv a -> PassName -> BackwardTransfers m l a - -> BackwardRewrites m l a g + -> BackwardRewrites m l a -> Graph m l -> a -> Fuel @@ -893,19 +840,23 @@ backward_rew check_maybe return_graph = back let Graph entry blockenv = g blocks = reverse $ G.postorder_dfs_from blockenv entry in do { solve depth name start transfers rewrites g exit_fact fuel + ; env <- getAllFacts + ; my_trace "facts after solving" (ppr env) $ return () ; eid <- freshBlockId "temporary entry id" - ; (rewritten, fuel) <- rewrite_blocks blocks emptyBlockEnv fuel - ; (rewritten, fuel) <- rewrite_blocks [Block eid entry] rewritten fuel + ; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel + -- We can't have the fact check fail on the bogus entry, which _may_ change + ; (rewritten, fuel) <- rewrite_blocks False [Block eid entry] rewritten fuel ; a <- getFact eid ; return (a, lgraphToGraph (LGraph eid rewritten), fuel) } - don't_rewrite g exit_fact fuel = + don't_rewrite facts g exit_fact fuel = do { (fp, _) <- - solve depth name emptyBlockEnv transfers rewrites g exit_fact fuel + solve depth name facts transfers rewrites g exit_fact fuel ; return (zdfFpOutputFact fp, g, fuel) } - inner_rew = case depth of RewriteShallow -> don't_rewrite - RewriteDeep -> rewrite emptyBlockEnv inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel) + inner_rew g a f = getAllFacts >>= \facts -> inner_rew' facts g a f + where inner_rew' = case depth of RewriteShallow -> don't_rewrite + RewriteDeep -> rewrite fixed_pt_and_fuel = do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx ; facts <- getAllFacts @@ -913,54 +864,56 @@ backward_rew check_maybe return_graph = back ; let fp = FP facts a changed (panic "no decoration?!") g ; return (fp, fuel) } - rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l)) + rewrite_blocks :: Bool -> [Block m l] -> (BlockEnv (Block m l)) -> Fuel -> DFM a (BlockEnv (Block m l), Fuel) - rewrite_blocks bs rewritten fuel = + rewrite_blocks check bs rewritten fuel = do { env <- factsEnv ; let rew [] r f = return (r, f) rew (b : bs) r f = - do { (r, f) <- rewrite_block env b r f; rew bs r f } + do { (r, f) <- rewrite_block check env b r f; rew bs r f } ; rew bs rewritten fuel } - rewrite_block env b rewritten fuel = + rewrite_block check env b rewritten fuel = let (h, l) = G.goto_end (G.unzip b) in case maybeRewriteWithFuel fuel $ either_last env l of - Nothing -> propagate fuel h (last_in env l) (ZLast l) rewritten + Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten Just g -> do { markGraphRewritten - ; g <- return_graph g + ; g <- areturn g ; (a, g, fuel) <- inner_rew g exit_fact fuel ; let G.Graph t new_blocks = g ; let rewritten' = new_blocks `plusUFM` rewritten - ; propagate fuel h a t rewritten' -- continue at entry of g + ; propagate check fuel h a t rewritten' -- continue at entry of g } either_last _env (LastExit) = br_exit rewrites either_last env (LastOther l) = br_last rewrites env l last_in _env (LastExit) = exit_fact last_in env (LastOther l) = bt_last_in transfers env l - propagate fuel (ZHead h m) a tail rewritten = + propagate check fuel (ZHead h m) a tail rewritten = case maybeRewriteWithFuel fuel $ br_middle rewrites a m of Nothing -> - propagate fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten + propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten Just g -> do { markGraphRewritten - ; g <- return_graph g - ; my_trace "Rewrote middle node" + ; g <- areturn g + ; my_trace "With Facts" (ppr a) $ return () + ; my_trace " Rewrote middle node" (f4sep [ppr m, text "to", pprGraph g]) $ return () ; (a, g, fuel) <- inner_rew g a fuel ; let Graph t newblocks = G.splice_tail g tail - ; propagate fuel h a t (newblocks `plusUFM` rewritten) } - propagate fuel (ZFirst id) a tail rewritten = + ; propagate check fuel h a t (newblocks `plusUFM` rewritten) } + propagate check fuel (ZFirst id) a tail rewritten = case maybeRewriteWithFuel fuel $ br_first rewrites a id of - Nothing -> do { checkFactMatch id a + Nothing -> do { if check then checkFactMatch id $ bt_first_in transfers a id + else return () ; return (insertBlock (Block id tail) rewritten, fuel) } Just g -> do { markGraphRewritten - ; g <- return_graph g + ; g <- areturn g ; my_trace "Rewrote first node" (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return () ; (a, g, fuel) <- inner_rew g a fuel - ; checkFactMatch id a + ; if check then checkFactMatch id a else return () ; let Graph t newblocks = G.splice_tail g tail ; let r = insertBlock (Block id t) (newblocks `plusUFM` rewritten) ; return (r, fuel) } @@ -1022,15 +975,16 @@ run dir name do_block blocks b = my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n) pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId - unchanged depth = my_nest depth (text "facts are unchanged") + unchanged depth = + my_nest depth (text "facts for" <+> graphId <+> text "are unchanged") + graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "" } + show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks)) + pprBlock (Block id t) = nest 2 (pprFact (id, t)) pprFacts depth n env = my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$ (nest 2 $ vcat $ map pprFact $ ufmToList env)) pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "" } - show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks)) - pprBlock (Block id t) = nest 2 (pprFact (id, t)) f4sep :: [SDoc] -> SDoc