X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipDataflow.hs;h=883de762f02a6b7d458903cdd9ad630d6fb4f382;hb=f44b39926869cd9b9a33f06ee807f7c664fd20c8;hp=b080adcdb84000a6c467c5c8c6615d749d325c9f;hpb=25628e2771424cae1b3366322e8ce6f8a85440f9;p=ghc-hetmet.git diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index b080adc..883de76 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -1,10 +1,11 @@ {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} -{-# OPTIONS -fno-allow-overlapping-instances -fglasgow-exts #-} +{-# OPTIONS -fglasgow-exts #-} -- -fglagow-exts for kind signatures module ZipDataflow ( DebugNodes(), RewritingDepth(..), LastOutFacts(..) , zdfSolveFrom, zdfRewriteFrom + , zdfSolveFromL , ForwardTransfers(..), BackwardTransfers(..) , ForwardRewrites(..), BackwardRewrites(..) , ForwardFixedPoint, BackwardFixedPoint @@ -14,20 +15,21 @@ module ZipDataflow , zdfDecoratedGraph -- not yet implemented , zdfFpContents , zdfFpLastOuts + , zdfBRewriteFromL, zdfFRewriteFromL ) where +import BlockId import CmmTx import DFMonad +import OptimizationFuel as F import MkZipCfg -import StackSlot import ZipCfg import qualified ZipCfg as G import Maybes import Outputable import Panic -import UniqFM import Control.Monad import Maybe @@ -145,26 +147,22 @@ newtype LastOutFacts a = LastOutFacts [(BlockId, a)] -- | A backward rewrite takes the same inputs as a backward transfer, -- but instead of producing a fact, it produces a replacement graph or Nothing. --- The type of the replacement graph is given as a type parameter 'g' --- of kind * -> * -> *. This design offers great flexibility to clients, --- 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 =================== -} @@ -232,7 +230,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. @@ -252,17 +250,26 @@ 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) + -> 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 + -> FuelMonad (fixedpt m l a ()) -- ^ Answers + zdfSolveFromL :: (DebugNodes m l, Outputable a) => 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 + -> LGraph m l -- Graph to be analyzed -> FuelMonad (fixedpt m l a ()) -- Answers + zdfSolveFromL b p l t a g = zdfSolveFrom b p l t a $ quickGraph g -- There are exactly two instances: forward and backward instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint @@ -295,19 +302,71 @@ 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 -> FuelMonad (fixedpt m l a (Graph m l)) +-- Temporarily lifting from Graph to LGraph -- an experiment to see how we +-- can eliminate some hysteresis between Graph and LGraph. +-- Perhaps Graph should be confined to dataflow code. +-- Trading space for time +quickGraph :: LastNode l => LGraph m l -> Graph m l +quickGraph g = Graph (ZLast $ mkBranchNode $ lg_entry g) $ lg_blocks g + +quickLGraph :: LastNode l => Int -> Graph m l -> FuelMonad (LGraph m l) +quickLGraph args (Graph (ZLast (LastOther l)) blockenv) + | isBranchNode l = return $ LGraph (branchNodeTarget l) args blockenv +quickLGraph args g = F.lGraphOfGraph g args + +fixptWithLGraph :: LastNode l => Int -> CommonFixedPoint m l fact (Graph m l) -> + FuelMonad (CommonFixedPoint m l fact (LGraph m l)) +fixptWithLGraph args cfp = + do fp_c <- quickLGraph args $ fp_contents cfp + return $ cfp {fp_contents = fp_c} + +ffixptWithLGraph :: LastNode l => Int -> ForwardFixedPoint m l fact (Graph m l) -> + FuelMonad (ForwardFixedPoint m l fact (LGraph m l)) +ffixptWithLGraph args fp = + do common <- fixptWithLGraph args $ ffp_common fp + return $ fp {ffp_common = common} + +zdfFRewriteFromL :: (DebugNodes m l, Outputable a) + => RewritingDepth -- whether to rewrite a rewritten graph + -> BlockEnv a -- initial facts (unbound == botton) + -> PassName + -> DataflowLattice a + -> ForwardTransfers m l a + -> ForwardRewrites m l a + -> a -- fact flowing in (at entry or exit) + -> LGraph m l + -> FuelMonad (ForwardFixedPoint m l a (LGraph m l)) +zdfFRewriteFromL d b p l t r a g@(LGraph _ args _) = + do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g + ffixptWithLGraph args fp + +zdfBRewriteFromL :: (DebugNodes m l, Outputable a) + => RewritingDepth -- whether to rewrite a rewritten graph + -> BlockEnv a -- initial facts (unbound == botton) + -> PassName + -> DataflowLattice a + -> BackwardTransfers m l a + -> BackwardRewrites m l a + -> a -- fact flowing in (at entry or exit) + -> LGraph m l + -> FuelMonad (BackwardFixedPoint m l a (LGraph m l)) +zdfBRewriteFromL d b p l t r a g@(LGraph _ args _) = + do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g + fixptWithLGraph args fp + + data RewritingDepth = RewriteShallow | RewriteDeep -- When a transformation proposes to rewrite a node, -- you can either ask the system to @@ -319,16 +378,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 @@ -349,38 +402,20 @@ solve_f :: (DebugNodes m l, Outputable a) solve_f env name lattice transfers in_fact g = 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 - -> FuelMonad (ForwardFixedPoint m l a (Graph m l)) -rewrite_f_graph depth start_facts name lattice transfers rewrites in_fact g = - runDFM 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 -> FuelMonad (ForwardFixedPoint m l a (Graph m l)) 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 @@ -388,26 +423,16 @@ rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g = areturn :: AGraph m l -> DFM a (Graph m l) areturn g = liftToDFM $ liftUniq $ graphOfAGraph g - -{- -graphToLGraph :: LastNode l => Graph m l -> DFM a (LGraph m l) -graphToLGraph (Graph (ZLast (LastOther l)) blockenv) - | isBranchNode l = return $ LGraph (branchNodeTarget l) blockenv -graphToLGraph (Graph tail blockenv) = - do id <- freshBlockId "temporary entry label" - return $ LGraph id $ insertBlock (Block id tail) blockenv --} - -- | Here we prefer not simply to slap on 'goto eid' because this -- introduces an unnecessary basic block at each rewrite, and we don't -- want to stress out the finite map more than necessary lgraphToGraph :: LastNode l => LGraph m l -> Graph m l -lgraphToGraph (LGraph eid blocks) = - if flip any (eltsUFM blocks) $ \block -> any (== eid) (succs block) then +lgraphToGraph (LGraph eid _ blocks) = + if flip any (eltsBlockEnv blocks) $ \block -> any (== eid) (succs block) then Graph (ZLast (mkBranchNode eid)) blocks else -- common case: entry is not a branch target - let Block _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!" - in Graph entry (delFromUFM blocks eid) + let Block _ _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!" + in Graph entry (delFromBlockEnv blocks eid) class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l @@ -423,11 +448,10 @@ fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a) 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 + where -- definitely a case of "I love lazy evaluation" + 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" ----------------------------------------------------------------------- @@ -461,34 +485,30 @@ fwd_pure_anal name env transfers in_fact g = 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 @@ -502,13 +522,13 @@ forward_sol check_maybe return_graph = forw solve finish in_fact (Graph entry blockenv) fuel = let blocks = G.postorder_dfs_from blockenv entry set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv) - set_successor_facts (Block id tail) fuel = + set_successor_facts (Block id _ tail) fuel = do { idfact <- getFact id ; (last_outs, fuel) <- case check_maybe fuel $ fr_first rewrites idfact id of 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) @@ -530,7 +550,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) @@ -545,7 +565,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) @@ -580,30 +600,27 @@ 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 @@ -618,10 +635,11 @@ forward_rew check_maybe return_graph = forw in do { solve depth name start transfers rewrites in_fact g fuel ; eid <- freshBlockId "temporary entry id" ; (rewritten, fuel) <- - rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel + rew_tail (ZFirst eid emptyStackInfo) + in_fact entry emptyBlockEnv fuel ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel ; a <- finish - ; return (a, lgraphToGraph (LGraph eid rewritten), fuel) + ; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel) } don't_rewrite facts finish in_fact g fuel = do { solve depth name facts transfers rewrites in_fact g fuel @@ -644,8 +662,8 @@ forward_rew check_maybe return_graph = forw rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l)) -> Fuel -> DFM a (BlockEnv (Block m l), Fuel) rewrite_blocks [] rewritten fuel = return (rewritten, fuel) - rewrite_blocks (G.Block id t : bs) rewritten fuel = - do let h = ZFirst id + rewrite_blocks (G.Block id off t : bs) rewritten fuel = + do let h = ZFirst id off a <- getFact id case check_maybe fuel $ fr_first rewrites a id of Nothing -> do { (rewritten, fuel) <- @@ -653,11 +671,11 @@ forward_rew check_maybe return_graph = forw 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 + ; let (blocks, h) = splice_head' h g ; (rewritten, fuel) <- - rew_tail h outfact t (blocks `plusUFM` rewritten) fuel + rew_tail h outfact t (blocks `plusBlockEnv` rewritten) fuel ; rewrite_blocks bs rewritten fuel } rew_tail head in' (G.ZTail m t) rewritten fuel = @@ -666,10 +684,10 @@ 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 + ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel } rew_tail h in' (G.ZLast l) rewritten fuel = my_trace "Rewriting last node" (ppr l) $ @@ -677,10 +695,10 @@ forward_rew check_maybe return_graph = forw 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) + ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel) } either_last rewrites in' (LastExit) = fr_exit rewrites in' either_last rewrites in' (LastOther l) = fr_last rewrites in' l @@ -690,7 +708,6 @@ forward_rew check_maybe return_graph = forw 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 @@ -708,66 +725,46 @@ solve_b env name lattice transfers exit_fact g = 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 - -> FuelMonad (BackwardFixedPoint m l a (Graph m l)) -rewrite_b_graph depth start_facts name lattice transfers rewrites exit_fact g = - runDFM 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 -> FuelMonad (BackwardFixedPoint m l a (Graph m l)) 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 -{-# 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 @@ -778,13 +775,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) @@ -800,31 +797,41 @@ backward_sol check_maybe return_graph = back ; (a, fuel) <- case check_maybe fuel $ last_rew env l of Nothing -> return (last_in env l, fuel) - Just g -> subsolve g exit_fact fuel + Just g -> do g' <- areturn g + my_trace "analysis rewrites last node" + (ppr l <+> pprGraph g') $ + subsolve g exit_fact fuel ; set_head_fact h a fuel ; return fuel } in do { fuel <- run "backward" name set_block_fact blocks fuel ; eid <- freshBlockId "temporary entry id" - ; fuel <- set_block_fact (Block eid entry) fuel + ; fuel <- set_block_fact (Block eid emptyStackInfo entry) fuel ; a <- getFact eid ; forgetFact eid ; return (a, fuel) } - set_head_fact (G.ZFirst id) a fuel = + set_head_fact (G.ZFirst id _) a fuel = case check_maybe fuel $ br_first rewrites a id of - Nothing -> do { my_trace "set_head_fact" (ppr id) $ + Nothing -> do { my_trace "set_head_fact" (ppr id <+> text "=" <+> + ppr (bt_first_in transfers a id)) $ setFact id $ bt_first_in transfers a id ; return fuel } - Just g -> do { (a, fuel) <- subsolve g a fuel - ; setFact id a + Just g -> do { g' <- areturn g + ; (a, fuel) <- my_trace "analysis rewrites first node" + (ppr id <+> pprGraph g') $ + subsolve g a fuel + ; setFact id $ bt_first_in transfers a id ; return fuel } set_head_fact (G.ZHead h m) a fuel = case check_maybe fuel $ br_middle rewrites a m of Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel - Just g -> do { (a, fuel) <- subsolve g a fuel + Just g -> do { g' <- areturn g + ; (a, fuel) <- my_trace "analysis rewrites middle node" + (ppr m <+> pprGraph g') $ + subsolve g a fuel ; set_head_fact h a fuel } fixed_point g exit_fact fuel = @@ -848,38 +855,35 @@ 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" {- ================================================================ -} -{-# 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 @@ -891,16 +895,21 @@ backward_rew check_maybe return_graph = back rewrite start g exit_fact fuel = 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 () + in do { (FP _ in_fact _ _ _, _) <- -- don't drop the entry fact! + 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 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) - } + ; (rewritten, fuel) <- + rewrite_blocks False [Block eid emptyStackInfo entry] + rewritten fuel + ; my_trace "eid" (ppr eid) $ return () + ; my_trace "exit_fact" (ppr exit_fact) $ return () + ; my_trace "in_fact" (ppr in_fact) $ return () + ; return (in_fact, lgraphToGraph (LGraph eid 0 rewritten), fuel) + } -- Remember: the entry fact computed by @solve@ accounts for rewriting don't_rewrite facts g exit_fact fuel = do { (fp, _) <- solve depth name facts transfers rewrites g exit_fact fuel @@ -930,10 +939,10 @@ backward_rew check_maybe return_graph = back 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 + ; let rewritten' = new_blocks `plusBlockEnv` rewritten ; propagate check fuel h a t rewritten' -- continue at entry of g } either_last _env (LastExit) = br_exit rewrites @@ -946,28 +955,31 @@ backward_rew check_maybe return_graph = back propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten Just g -> do { markGraphRewritten - ; g <- return_graph g + ; 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 check fuel h a t (newblocks `plusUFM` rewritten) } - propagate check fuel (ZFirst id) a tail rewritten = + ; my_trace "propagating facts" (ppr a) $ + propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) } + propagate check fuel (ZFirst id off) a tail rewritten = case maybeRewriteWithFuel fuel $ br_first rewrites a id of - Nothing -> do { if check then checkFactMatch id $ bt_first_in transfers a id + Nothing -> do { if check then + checkFactMatch id $ bt_first_in transfers a id else return () - ; return (insertBlock (Block id tail) rewritten, fuel) } + ; return (insertBlock (Block id off 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 - ; if check then checkFactMatch id a else return () + ; if check then checkFactMatch id (bt_first_in transfers a id) + else return () ; let Graph t newblocks = G.splice_tail g tail - ; let r = insertBlock (Block id t) (newblocks `plusUFM` rewritten) + ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten) ; return (r, fuel) } in fixed_pt_and_fuel @@ -991,7 +1003,7 @@ instance FixedPoint ForwardFixedPoint where dump_things :: Bool -dump_things = True +dump_things = False my_trace :: String -> SDoc -> a -> a my_trace = if dump_things then pprTrace else \_ _ a -> a @@ -1005,12 +1017,16 @@ run dir name do_block blocks b = where -- N.B. Each iteration starts with the same transaction limit; -- only the rewrites in the final iteration actually count - trace_block b block = - my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $ - do_block block b + trace_block (b, cnt) block = + do b' <- my_trace "about to do" (text name <+> text "on" <+> + ppr (blockId block) <+> ppr cnt) $ + do_block block b + return (b', cnt + 1) iterate n = do { markFactsUnchanged - ; b <- foldM trace_block b blocks + ; (b, _) <- + my_trace "block count:" (ppr (length blocks)) $ + foldM trace_block (b, 0 :: Int) blocks ; changed <- factsStatus ; facts <- getAllFacts ; let depth = 0 -- was nesting depth @@ -1030,13 +1046,14 @@ run dir name do_block blocks b = unchanged depth = my_nest depth (text "facts for" <+> graphId <+> text "are unchanged") - graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "" } + 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)) + pprBlock (Block id off t) = nest 2 (pprFact' (id, off, 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) + (nest 2 $ vcat $ map pprFact $ blockEnvToList env)) + pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) + pprFact' (id, off, a) = hang (ppr id <> parens (ppr off) <> colon) 4 (ppr a) f4sep :: [SDoc] -> SDoc @@ -1048,11 +1065,11 @@ subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => m f a -> m f a subAnalysis' m = do { a <- subAnalysis $ - do { a <- m; facts <- getAllFacts - ; my_trace "after sub-analysis facts are" (pprFacts facts) $ + do { a <- m; -- facts <- getAllFacts + ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $ return a } - ; facts <- getAllFacts - ; my_trace "in parent analysis facts are" (pprFacts facts) $ + -- ; facts <- getAllFacts + ; -- my_trace "in parent analysis facts are" (pprFacts facts) $ return a } - where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env - pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) + -- where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env + -- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)