X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipDataflow.hs;h=2087b9ce345e98b43bdd8fe98e1c0d576a5422c8;hb=bd2264ad7b4346782efbb5bb786686ec265a5e90;hp=290faa20bda2edd105541ff2ac4ddc4dc4f4f562;hpb=8b7eaa404043294bd4cb4a0322ac1f7115bad6a0;p=ghc-hetmet.git diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index 290faa2..2087b9c 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -1,5 +1,4 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} -{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses #-} module ZipDataflow ( Answer(..) , BComputation(..), BAnalysis, BTransformation, BFunctionalTransformation @@ -18,7 +17,7 @@ where import CmmTx import DFMonad -import ZipCfg hiding (freshBlockId) -- use version from DFMonad +import ZipCfg import qualified ZipCfg as G import Outputable @@ -29,6 +28,8 @@ import UniqSupply import Control.Monad import Maybe +#include "HsVersions.h" + {- \section{A very polymorphic infrastructure for dataflow problems} @@ -58,27 +59,50 @@ data Answer m l a = Dataflow a | Rewrite (Graph m l) {- -\subsection {Descriptions of dataflow passes} +============== Descriptions of dataflow passes} ================ -\paragraph{Passes for backward dataflow problems} +------ Passes for backward dataflow problemsa The computation of a fact is the basis of a dataflow pass. -A~computation takes not one but two type parameters: -\begin{itemize} -\item -Type parameter [['i]] is an input, from which it should be possible to -derived a dataflow fact of interest. -For example, [['i]] might be equal to a fact, or it might be a tuple -of which one element is a fact. -\item -Type parameter [['o]] is an output, or possibly a function from -[[txlimit]] to an output -\end{itemize} -Backward analyses compute [[in]] facts (facts on inedges). -<>= +A computation takes *four* type parameters: + + * 'middle' and 'last' are the types of the middle + and last nodes of the graph over which the dataflow + solution is being computed + + * 'input' is an input, from which it should be possible to + derive a dataflow fact of interest. For example, 'input' might + be equal to a fact, or it might be a tuple of which one element + is a fact. + * 'output' is an output, or possibly a function from 'fuel' to an + output + +A computation is interesting for any pair of 'middle' and 'last' type +parameters that can form a reasonable graph. But it is not useful to +instantiate 'input' and 'output' arbitrarily. Rather, only certain +combinations of instances are likely to be useful, such as those shown +below. + +Backward analyses compute *in* facts (facts on inedges). -} +-- A dataflow pass requires a name and a transfer function for each of +-- four kinds of nodes: +-- first (the BlockId), +-- middle +-- last +-- LastExit + +-- A 'BComputation' describes a complete backward dataflow pass, as a +-- record of transfer functions. Because the analysis works +-- back-to-front, we write the exit node at the beginning. +-- +-- So there is +-- an 'input' for each out-edge of the node +-- (hence (BlockId -> input) for bc_last_in) +-- an 'output' for the in-edge of the node + data BComputation middle last input output = BComp { bc_name :: String , bc_exit_in :: output @@ -92,13 +116,17 @@ data BComputation middle last input output = BComp -- * A pure transformation computes no facts but only changes the graph. -- * A fully general pass both computes a fact and rewrites the graph, -- respecting the current transaction limit. - +-- type BAnalysis m l a = BComputation m l a a type BTransformation m l a = BComputation m l a (Maybe (UniqSM (Graph m l))) type BFunctionalTransformation m l a = BComputation m l a (Maybe (Graph m l)) + -- ToDo: consider replacing UniqSM (Graph l m) with (AGraph m l) + +type BPass m l a = BComputation m l a (OptimizationFuel -> DFM a (Answer m l a)) +type BUnlimitedPass m l a = BComputation m l a ( DFM a (Answer m l a)) -type BPass m l a = BComputation m l a (Txlimit -> DFM a (Answer m l a)) -type BUnlimitedPass m l a = BComputation m l a ( DFM a (Answer m l a)) + -- (DFM a t) maintains the (BlockId -> a) map + -- ToDo: overlap with bc_last_in?? {- \paragraph{Passes for forward dataflow problems} @@ -132,8 +160,8 @@ type FAnalysis m l a = FComputation m l a a (LastOutFacts a) type FTransformation m l a = FComputation m l a (Maybe (UniqSM (Graph m l))) (Maybe (UniqSM (Graph m l))) type FPass m l a = FComputation m l a - (Txlimit -> DFM a (Answer m l a)) - (Txlimit -> DFM a (Answer m l (LastOutFacts a))) + (OptimizationFuel -> DFM a (Answer m l a)) + (OptimizationFuel -> DFM a (Answer m l (LastOutFacts a))) type FUnlimitedPass m l a = FComputation m l a (DFM a (Answer m l a)) @@ -177,9 +205,9 @@ It's possible we could make these things more regular. -- | The analysis functions set properties on unique IDs. -run_b_anal :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) => +run_b_anal :: (DebugNodes m l, LastNode l, Outputable a) => BAnalysis m l a -> LGraph m l -> DFA a () -run_f_anal :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) => +run_f_anal :: (DebugNodes m l, LastNode l, Outputable a) => FAnalysis m l a -> a -> LGraph m l -> DFA a () -- ^ extra parameter is the entry fact @@ -208,10 +236,10 @@ fold_edge_facts_with_nodes_b :: LastNode l class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l -refine_f_anal :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) => +refine_f_anal :: (DebugNodes m l, LastNode l, Outputable a) => FAnalysis m l a -> LGraph m l -> DFA a () -> DFA a () -refine_b_anal :: forall m l a . (DebugNodes m l, LastNode l, Outputable a) => +refine_b_anal :: (DebugNodes m l, LastNode l, Outputable a) => BAnalysis m l a -> LGraph m l -> DFA a () -> DFA a () b_rewrite :: (DebugNodes m l, Outputable a) => @@ -297,8 +325,7 @@ refine_b_anal comp graph initial = set_block_fact () b@(G.Block id _) = let (h, l) = G.goto_end (G.unzip b) in do env <- factsEnv - let block_in = head_in h (last_in comp env l) -- 'in' fact for the block - setFact id block_in + setFact id $ head_in h (last_in comp env l) -- 'in' fact for the block head_in (G.ZHead h m) out = head_in h (bc_middle_in comp out m) head_in (G.ZFirst id) out = bc_first_in comp out id @@ -338,10 +365,10 @@ fold_edge_facts_with_nodes_b fl fm ff comp graph env z = -- To do this, we need a locally modified computation that allows an -- ``exit fact'' to flow into the exit node. -comp_with_exit_b :: BComputation m l i (Txlimit -> DFM f (Answer m l o)) -> o -> - BComputation m l i (Txlimit -> DFM f (Answer m l o)) +comp_with_exit_b :: BComputation m l i (OptimizationFuel -> DFM f (Answer m l o)) -> o -> + BComputation m l i (OptimizationFuel -> DFM f (Answer m l o)) comp_with_exit_b comp exit_fact = - comp { bc_exit_in = \_txlim -> return $ Dataflow $ exit_fact } + comp { bc_exit_in = \_fuel -> return $ Dataflow $ exit_fact } -- | Given this function, we can now solve a graph simply by doing a -- backward analysis on the modified computation. Note we have to be @@ -352,56 +379,60 @@ comp_with_exit_b comp exit_fact = -- Rewrite should always use exactly one of these monadic operations. solve_graph_b :: - forall m l a . (DebugNodes m l, Outputable a) => - BPass m l a -> Txlimit -> G.LGraph m l -> a -> DFM a (Txlimit, a) -solve_graph_b comp txlim graph exit_fact = - general_backward (comp_with_exit_b comp exit_fact) txlim graph + (DebugNodes m l, Outputable a) => + BPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> DFM a (OptimizationFuel, a) +solve_graph_b comp fuel graph exit_fact = + general_backward (comp_with_exit_b comp exit_fact) fuel graph where - general_backward :: BPass m l a -> Txlimit -> G.LGraph m l -> DFM a (Txlimit, a) - general_backward comp txlim graph = - let set_block_fact :: Txlimit -> G.Block m l -> DFM a Txlimit - set_block_fact txlim b = - do { (txlim, block_in) <- + -- general_backward :: BPass m l a -> OptimizationFuel -> G.LGraph m l -> DFM a (OptimizationFuel, a) + general_backward comp fuel graph = + let -- set_block_fact :: OptimizationFuel -> G.Block m l -> DFM a OptimizationFuel + set_block_fact fuel b = + do { (fuel, block_in) <- let (h, l) = G.goto_end (G.unzip b) in - factsEnv >>= \env -> last_in comp env l txlim >>= \x -> + factsEnv >>= \env -> last_in comp env l fuel >>= \x -> case x of - Dataflow a -> head_in txlim h a + Dataflow a -> head_in fuel h a Rewrite g -> do { bot <- botFact - ; g <- lgraphOfGraph g - ; (txlim, a) <- subAnalysis' $ - solve_graph_b comp (txlim-1) g bot - ; head_in txlim h a } + ; (fuel, a) <- subAnalysis' $ + solve_graph_b_g comp (fuel-1) g bot + ; head_in fuel h a } ; my_trace "result of" (text (bc_name comp) <+> text "on" <+> ppr (G.blockId b) <+> text "is" <+> ppr block_in) $ setFact (G.blockId b) block_in - ; return txlim + ; return fuel } - head_in txlim (G.ZHead h m) out = - bc_middle_in comp out m txlim >>= \x -> case x of - Dataflow a -> head_in txlim h a + head_in fuel (G.ZHead h m) out = + bc_middle_in comp out m fuel >>= \x -> case x of + Dataflow a -> head_in fuel h a Rewrite g -> - do { g <- lgraphOfGraph g - ; (txlim, a) <- subAnalysis' $ solve_graph_b comp (txlim-1) g out - ; my_trace "Rewrote middle node" (f4sep [ppr m, text "to", ppr g]) $ - head_in txlim h a } - head_in txlim (G.ZFirst id) out = - bc_first_in comp out id txlim >>= \x -> case x of - Dataflow a -> return (txlim, a) - Rewrite g -> do { g <- lgraphOfGraph g - ; subAnalysis' $ solve_graph_b comp (txlim-1) g out } - - in do { txlim <- - run "backward" (bc_name comp) (return ()) set_block_fact txlim blocks - ; a <- getFact (G.gr_entry graph) + do { (fuel, a) <- subAnalysis' $ solve_graph_b_g comp (fuel-1) g out + ; my_trace "Rewrote middle node" + (f4sep [ppr m, text "to", pprGraph g]) $ + head_in fuel h a } + head_in fuel (G.ZFirst id) out = + bc_first_in comp out id fuel >>= \x -> case x of + Dataflow a -> return (fuel, a) + Rewrite g -> do { subAnalysis' $ solve_graph_b_g comp (fuel-1) g out } + + in do { fuel <- + run "backward" (bc_name comp) (return ()) set_block_fact fuel blocks + ; a <- getFact (G.lg_entry graph) ; facts <- allFacts ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $ - return (txlim, a) } + return (fuel, a) } blocks = reverse (G.postorder_dfs graph) pprFacts g env a = (ppr a <+> text "with") $$ vcat (pprLgraph g : map pprFact (ufmToList env)) pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) +solve_graph_b_g :: + (DebugNodes m l, Outputable a) => + BPass m l a -> OptimizationFuel -> G.Graph m l -> a -> DFM a (OptimizationFuel, a) +solve_graph_b_g comp fuel graph exit_fact = + do { g <- lgraphOfGraph graph ; solve_graph_b comp fuel g exit_fact } + lgraphOfGraph :: G.Graph m l -> DFM f (G.LGraph m l) lgraphOfGraph g = @@ -411,6 +442,16 @@ lgraphOfGraph g = labelGraph :: BlockId -> G.Graph m l -> G.LGraph m l labelGraph id (Graph tail blocks) = LGraph id (insertBlock (Block id tail) blocks) +-- | We can remove the entry label of an LGraph and remove +-- it, leaving a Graph. Notice that this operation is NOT SAFE if a +-- block within the LGraph branches to the entry point. It should +-- be used only to complement 'lgraphOfGraph' above. + +remove_entry_label :: LGraph m l -> Graph m l +remove_entry_label g = + let FGraph e (ZBlock (ZFirst id) tail) others = entry g + in ASSERT (id == e) Graph tail others + {- We solve and rewrite in two passes: the first pass iterates to a fixed point to reach a dataflow solution, and the second pass uses that @@ -423,77 +464,98 @@ The tail is in final form; the head is still to be rewritten. -} solve_and_rewrite_b :: - forall m l a. (DebugNodes m l, Outputable a) => - BPass m l a -> Txlimit -> LGraph m l -> a -> DFM a (Txlimit, a, LGraph m l) + (DebugNodes m l, Outputable a) => + BPass m l a -> OptimizationFuel -> LGraph m l -> a -> DFM a (OptimizationFuel, a, LGraph m l) +solve_and_rewrite_b_graph :: + (DebugNodes m l, Outputable a) => + BPass m l a -> OptimizationFuel -> Graph m l -> a -> DFM a (OptimizationFuel, a, Graph m l) -solve_and_rewrite_b comp txlim graph exit_fact = - do { (_, a) <- solve_graph_b comp txlim graph exit_fact -- pass 1 + +solve_and_rewrite_b comp fuel graph exit_fact = + do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1 ; facts <- allFacts - ; (txlim, g) <- -- pass 2 + ; (fuel, g) <- -- pass 2 my_trace "Solution to graph after pass 1 is" (pprFacts graph facts) $ - backward_rewrite (comp_with_exit_b comp exit_fact) txlim graph + backward_rewrite (comp_with_exit_b comp exit_fact) fuel graph ; facts <- allFacts ; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $ - return (txlim, a, g) } + return (fuel, a, g) } where pprFacts g env = vcat (pprLgraph g : map pprFact (ufmToList env)) pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - eid = G.gr_entry graph - backward_rewrite comp txlim graph = - rewrite_blocks comp txlim emptyBlockEnv $ reverse (G.postorder_dfs graph) - rewrite_blocks :: - BPass m l a -> Txlimit -> - BlockEnv (Block m l) -> [Block m l] -> DFM a (Txlimit,G.LGraph m l) - rewrite_blocks _comp txlim rewritten [] = return (txlim, G.LGraph eid rewritten) - rewrite_blocks comp txlim rewritten (b:bs) = - let rewrite_next_block txlim = + eid = G.lg_entry graph + backward_rewrite comp fuel graph = + rewrite_blocks comp fuel emptyBlockEnv $ reverse (G.postorder_dfs graph) + -- rewrite_blocks :: + -- BPass m l a -> OptimizationFuel -> + -- BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel,G.LGraph m l) + rewrite_blocks _comp fuel rewritten [] = return (fuel, G.LGraph eid rewritten) + rewrite_blocks comp fuel rewritten (b:bs) = + let rewrite_next_block fuel = let (h, l) = G.goto_end (G.unzip b) in - factsEnv >>= \env -> last_in comp env l txlim >>= \x -> case x of - Dataflow a -> propagate txlim h a (G.ZLast l) rewritten - Rewrite g -> -- see Note [Rewriting labelled LGraphs] - do { bot <- botFact - ; g <- lgraphOfGraph g - ; (txlim, a, g') <- solve_and_rewrite_b comp (txlim-1) g bot - ; let G.Graph t new_blocks = G.remove_entry_label g' - ; markGraphRewritten - ; let rewritten' = plusUFM new_blocks rewritten - ; -- continue at entry of g - propagate txlim h a t rewritten' + factsEnv >>= \env -> last_in comp env l fuel >>= \x -> case x of + Dataflow a -> propagate fuel h a (G.ZLast l) rewritten + Rewrite g -> + do { markGraphRewritten + ; bot <- botFact + ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g bot + ; 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 :: Txlimit -> G.ZHead m -> a -> G.ZTail m l -> - BlockEnv (Block m l) -> DFM a (Txlimit, G.LGraph m l) - propagate txlim (G.ZHead h m) out tail rewritten = - bc_middle_in comp out m txlim >>= \x -> case x of - Dataflow a -> propagate txlim h a (G.ZTail m tail) rewritten + -- propagate :: OptimizationFuel -- Number of rewrites permitted + -- -> G.ZHead m -- Part of current block yet to be rewritten + -- -> a -- Fact on edge between head and tail + -- -> G.ZTail m l -- Part of current block already rewritten + -- -> BlockEnv (Block m l) -- Blocks already rewritten + -- -> DFM a (OptimizationFuel, G.LGraph m l) + propagate fuel (G.ZHead h m) out tail rewritten = + bc_middle_in comp out m fuel >>= \x -> case x of + Dataflow a -> propagate fuel h a (G.ZTail m tail) rewritten Rewrite g -> - do { g <- lgraphOfGraph g - ; (txlim, a, g') <- solve_and_rewrite_b comp (txlim-1) g out - ; markGraphRewritten - ; let (t, g'') = G.splice_tail g' tail - ; let rewritten' = plusUFM (G.gr_blocks g'') rewritten - ; my_trace "Rewrote middle node" (f4sep [ppr m, text "to", ppr g]) $ - propagate txlim h a t rewritten' } - propagate txlim h@(G.ZFirst id) out tail rewritten = - bc_first_in comp out id txlim >>= \x -> case x of + do { markGraphRewritten + ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out + ; let G.Graph t newblocks = G.splice_tail g' tail + ; my_trace "Rewrote middle node" + (f4sep [ppr m, text "to", pprGraph g']) $ + propagate fuel h a t (newblocks `plusUFM` rewritten) } + propagate fuel h@(G.ZFirst id) out tail rewritten = + bc_first_in comp out id fuel >>= \x -> case x of Dataflow a -> let b = G.Block id tail in do { checkFactMatch id a - ; rewrite_blocks comp txlim (extendBlockEnv rewritten id b) bs } - Rewrite fg -> - do { g <- lgraphOfGraph fg - ; (txlim, a, g') <- solve_and_rewrite_b comp (txlim-1) g out - ; markGraphRewritten - ; let (t, g'') = G.splice_tail g' tail - ; let rewritten' = plusUFM (G.gr_blocks g'') rewritten - ; my_trace "Rewrote label " (f4sep [ppr id, text "to", ppr g]) $ - propagate txlim h a t rewritten' } - in rewrite_next_block txlim + ; rewrite_blocks comp fuel (extendBlockEnv rewritten id b) bs } + Rewrite g -> + do { markGraphRewritten + ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (fuel-1) g out + ; let G.Graph t newblocks = G.splice_tail g' tail + ; my_trace "Rewrote label " (f4sep [ppr id,text "to",pprGraph g])$ + propagate fuel h a t (newblocks `plusUFM` rewritten) } + in rewrite_next_block fuel + +{- Note [Rewriting labelled LGraphs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's hugely annoying that we get in an LGraph and in order to solve it +we have to slap on a new label which we then immediately strip off. +But the alternative is to have all the iterative solvers work on +Graphs, and then suddenly instead of a single case (ZBlock) every +solver has to deal with two cases (ZBlock and ZTail). So until +somebody comes along who is smart enough to do this and still leave +the code understandable for mortals, it stays as it is. + +(One part of the solution will be postorder_dfs_from_except.) +-} + +solve_and_rewrite_b_graph comp fuel graph exit_fact = + do g <- lgraphOfGraph graph + (fuel, a, g') <- solve_and_rewrite_b comp fuel g exit_fact + return (fuel, a, remove_entry_label g') b_rewrite comp g = - do { txlim <- liftTx txRemaining + do { fuel <- liftTx txRemaining ; bot <- botFact - ; (txlim', _, gc) <- solve_and_rewrite_b comp txlim g bot - ; liftTx $ txDecrement (bc_name comp) txlim txlim' + ; (fuel', _, gc) <- solve_and_rewrite_b comp fuel g bot + ; liftTx $ txDecrement (bc_name comp) fuel fuel' ; return gc } @@ -507,15 +569,15 @@ let debug s (f, comp) = let pr = Printf.eprintf in let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in let rewr node g = pr "%s rewrites %s to \n" comp.name node in - let wrap f nodestring node txlim = - let answer = f node txlim in + let wrap f nodestring node fuel = + let answer = f node fuel in let () = match answer with | Dataflow a -> fact "in " (nodestring node) a | Rewrite g -> rewr (nodestring node) g in answer in - let wrapout f nodestring out node txlim = + let wrapout f nodestring out node fuel = fact "out" (nodestring node) out; - wrap (f out) nodestring node txlim in + wrap (f out) nodestring node fuel in let last_in = wrap comp.last_in (RS.rtl << G.last_instr) in let middle_in = wrapout comp.middle_in (RS.rtl << G.mid_instr) in let first_in = @@ -528,39 +590,39 @@ anal_b comp = comp { bc_last_in = wrap2 $ bc_last_in comp , bc_exit_in = wrap0 $ bc_exit_in comp , bc_middle_in = wrap2 $ bc_middle_in comp , bc_first_in = wrap2 $ bc_first_in comp } - where wrap2 f out node _txlim = return $ Dataflow (f out node) - wrap0 fact _txlim = return $ Dataflow fact + where wrap2 f out node _fuel = return $ Dataflow (f out node) + wrap0 fact _fuel = return $ Dataflow fact ignore_transactions_b comp = comp { bc_last_in = wrap2 $ bc_last_in comp , bc_exit_in = wrap0 $ bc_exit_in comp , bc_middle_in = wrap2 $ bc_middle_in comp , bc_first_in = wrap2 $ bc_first_in comp } - where wrap2 f out node _txlim = f out node - wrap0 fact _txlim = fact + where wrap2 f out node _fuel = f out node + wrap0 fact _fuel = fact -answer' :: (b -> DFM f (Graph m l)) -> Txlimit -> Maybe b -> a -> DFM f (Answer m l a) -answer' lift txlim r a = - case r of Just gc | txlim > 0 -> do { g <- lift gc; return $ Rewrite g } +answer' :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a) +answer' lift fuel r a = + case r of Just gc | fuel > 0 -> do { g <- lift gc; return $ Rewrite g } _ -> return $ Dataflow a unlimited_answer' - :: (b -> DFM f (Graph m l)) -> Txlimit -> Maybe b -> a -> DFM f (Answer m l a) -unlimited_answer' lift _txlim r a = + :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a) +unlimited_answer' lift _fuel r a = case r of Just gc -> do { g <- lift gc; return $ Rewrite g } _ -> return $ Dataflow a -combine_a_t_with :: (Txlimit -> Maybe b -> a -> DFM a (Answer m l a)) -> +combine_a_t_with :: (OptimizationFuel -> Maybe b -> a -> DFM a (Answer m l a)) -> BAnalysis m l a -> BComputation m l a (Maybe b) -> BPass m l a combine_a_t_with answer anal tx = - let last_in env l txlim = - answer txlim (bc_last_in tx env l) (bc_last_in anal env l) - exit_in txlim = answer txlim (bc_exit_in tx) (bc_exit_in anal) - middle_in out m txlim = - answer txlim (bc_middle_in tx out m) (bc_middle_in anal out m) - first_in out f txlim = - answer txlim (bc_first_in tx out f) (bc_first_in anal out f) + let last_in env l fuel = + answer fuel (bc_last_in tx env l) (bc_last_in anal env l) + exit_in fuel = answer fuel (bc_exit_in tx) (bc_exit_in anal) + middle_in out m fuel = + answer fuel (bc_middle_in tx out m) (bc_middle_in anal out m) + first_in out f fuel = + answer fuel (bc_first_in tx out f) (bc_first_in anal out f) in BComp { bc_name = concat [bc_name anal, " and ", bc_name tx] , bc_last_in = last_in, bc_middle_in = middle_in , bc_first_in = first_in, bc_exit_in = exit_in } @@ -583,7 +645,7 @@ my_trace :: String -> SDoc -> a -> a my_trace = if dump_things then pprTrace else \_ _ a -> a run_f_anal comp entry_fact graph = refine_f_anal comp graph set_entry - where set_entry = setFact (G.gr_entry graph) entry_fact + where set_entry = setFact (G.lg_entry graph) entry_fact refine_f_anal comp graph initial = run "forward" (fc_name comp) initial set_successor_facts () blocks @@ -591,7 +653,7 @@ refine_f_anal comp graph initial = set_successor_facts () (G.Block id t) = let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t forward in' (G.ZLast l) = setEdgeFacts (last_outs comp in' l) - _blockname = if id == G.gr_entry graph then "" else show id + _blockname = if id == G.lg_entry graph then "" else show id in getFact id >>= \a -> forward (fc_first_out comp a id) t setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs setEdgeFact (id, a) = setFact id a @@ -607,65 +669,67 @@ last_outs comp i (G.LastOther l) = fc_last_outs comp i l comp_with_exit_f :: FPass m l a -> BlockId -> FPass m l a comp_with_exit_f comp exit_fact_id = comp { fc_exit_outs = exit_outs } - where exit_outs in' _txlimit = - return $ Dataflow $ LastOutFacts [(exit_fact_id, in')] + where exit_outs in' _fuel = return $ Dataflow $ LastOutFacts [(exit_fact_id, in')] -- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a -- forward analysis on the modified computation. solve_graph_f :: - forall m l a . (DebugNodes m l, Outputable a) => - FPass m l a -> Txlimit -> G.LGraph m l -> a -> - DFM a (Txlimit, a, LastOutFacts a) -solve_graph_f comp txlim g in_fact = + (DebugNodes m l, Outputable a) => + FPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> + DFM a (OptimizationFuel, a, LastOutFacts a) +solve_graph_f comp fuel g in_fact = do { exit_fact_id <- freshBlockId "proxy for exit node" - ; txlim <- general_forward (comp_with_exit_f comp exit_fact_id) txlim in_fact g + ; fuel <- general_forward (comp_with_exit_f comp exit_fact_id) fuel in_fact g ; a <- getFact exit_fact_id ; outs <- lastOutFacts ; forgetFact exit_fact_id -- close space leak - ; return (txlim, a, LastOutFacts outs) } + ; return (fuel, a, LastOutFacts outs) } where - general_forward :: FPass m l a -> Txlimit -> a -> G.LGraph m l -> DFM a Txlimit - general_forward comp txlim entry_fact graph = + -- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel + general_forward comp fuel entry_fact graph = let blocks = G.postorder_dfs g - is_local id = isJust $ lookupBlockEnv (G.gr_blocks g) id - set_or_save :: LastOutFacts a -> DFM a () + is_local id = isJust $ lookupBlockEnv (G.lg_blocks g) id + -- set_or_save :: LastOutFacts a -> DFM a () set_or_save (LastOutFacts l) = mapM_ set_or_save_one l set_or_save_one (id, a) = if is_local id then setFact id a else addLastOutFact (id, a) - set_entry = setFact (G.gr_entry graph) entry_fact + set_entry = setFact (G.lg_entry graph) entry_fact - set_successor_facts txlim b = - let set_tail_facts txlim in' (G.ZTail m t) = + set_successor_facts fuel b = + let set_tail_facts fuel in' (G.ZTail m t) = my_trace "Solving middle node" (ppr m) $ - fc_middle_out comp in' m txlim >>= \ x -> case x of - Dataflow a -> set_tail_facts txlim a t + fc_middle_out comp in' m fuel >>= \ x -> case x of + Dataflow a -> set_tail_facts fuel a t Rewrite g -> - do g <- lgraphOfGraph g - (txlim, out, last_outs) <- subAnalysis' $ - solve_graph_f comp (txlim-1) g in' + do (fuel, out, last_outs) <- + subAnalysis' $ solve_graph_f_g comp (fuel-1) g in' set_or_save last_outs - set_tail_facts txlim out t - set_tail_facts txlim in' (G.ZLast l) = - last_outs comp in' l txlim >>= \x -> case x of - Dataflow outs -> do { set_or_save outs; return txlim } + set_tail_facts fuel out t + set_tail_facts fuel in' (G.ZLast l) = + last_outs comp in' l fuel >>= \x -> case x of + Dataflow outs -> do { set_or_save outs; return fuel } Rewrite g -> - do g <- lgraphOfGraph g - (txlim, _, last_outs) <- subAnalysis' $ - solve_graph_f comp (txlim-1) g in' + do (fuel, _, last_outs) <- + subAnalysis' $ solve_graph_f_g comp (fuel-1) g in' set_or_save last_outs - return txlim + return fuel G.Block id t = b in do idfact <- getFact id - infact <- fc_first_out comp idfact id txlim - case infact of Dataflow a -> set_tail_facts txlim a t + infact <- fc_first_out comp idfact id fuel + case infact of Dataflow a -> set_tail_facts fuel a t Rewrite g -> - do g <- lgraphOfGraph g - (txlim, out, last_outs) <- subAnalysis' $ - solve_graph_f comp (txlim-1) g idfact + do (fuel, out, last_outs) <- subAnalysis' $ + solve_graph_f_g comp (fuel-1) g idfact set_or_save last_outs - set_tail_facts txlim out t - in run "forward" (fc_name comp) set_entry set_successor_facts txlim blocks + set_tail_facts fuel out t + in run "forward" (fc_name comp) set_entry set_successor_facts fuel blocks +solve_graph_f_g :: + (DebugNodes m l, Outputable a) => + FPass m l a -> OptimizationFuel -> G.Graph m l -> a -> + DFM a (OptimizationFuel, a, LastOutFacts a) +solve_graph_f_g comp fuel graph in_fact = + do { g <- lgraphOfGraph graph ; solve_graph_f comp fuel g in_fact } {- @@ -678,76 +742,79 @@ between a head and tail. The tail is in final form; the head is still to be rewritten. -} solve_and_rewrite_f :: - forall m l a . (DebugNodes m l, Outputable a) => - FPass m l a -> Txlimit -> LGraph m l -> a -> DFM a (Txlimit, a, LGraph m l) -solve_and_rewrite_f comp txlim graph in_fact = - do solve_graph_f comp txlim graph in_fact -- pass 1 + (DebugNodes m l, Outputable a) => + FPass m l a -> OptimizationFuel -> LGraph m l -> a -> + DFM a (OptimizationFuel, a, LGraph m l) +solve_and_rewrite_f comp fuel graph in_fact = + do solve_graph_f comp fuel graph in_fact -- pass 1 exit_id <- freshBlockId "proxy for exit node" - (txlim, g) <- forward_rewrite (comp_with_exit_f comp exit_id) txlim graph in_fact + (fuel, g) <- forward_rewrite (comp_with_exit_f comp exit_id) fuel graph in_fact exit_fact <- getFact exit_id - return (txlim, exit_fact, g) + return (fuel, exit_fact, g) + +solve_and_rewrite_f_graph :: + (DebugNodes m l, Outputable a) => + FPass m l a -> OptimizationFuel -> Graph m l -> a -> + DFM a (OptimizationFuel, a, Graph m l) +solve_and_rewrite_f_graph comp fuel graph in_fact = + do g <- lgraphOfGraph graph + (fuel, a, g') <- solve_and_rewrite_f comp fuel g in_fact + return (fuel, a, remove_entry_label g') forward_rewrite :: - forall m l a . (DebugNodes m l, Outputable a) => - FPass m l a -> Txlimit -> G.LGraph m l -> a -> DFM a (Txlimit, G.LGraph m l) -forward_rewrite comp txlim graph entry_fact = + (DebugNodes m l, Outputable a) => + FPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> + DFM a (OptimizationFuel, G.LGraph m l) +forward_rewrite comp fuel graph entry_fact = do setFact eid entry_fact - rewrite_blocks txlim emptyBlockEnv (G.postorder_dfs graph) + rewrite_blocks fuel emptyBlockEnv (G.postorder_dfs graph) where - eid = G.gr_entry graph - is_local id = isJust $ lookupBlockEnv (G.gr_blocks graph) id - set_or_save :: LastOutFacts a -> DFM a () + eid = G.lg_entry graph + is_local id = isJust $ lookupBlockEnv (G.lg_blocks graph) id + -- set_or_save :: LastOutFacts a -> DFM a () set_or_save (LastOutFacts l) = mapM_ set_or_save_one l set_or_save_one (id, a) = if is_local id then checkFactMatch id a else panic "set fact outside graph during rewriting pass?!" - rewrite_blocks :: - Txlimit -> BlockEnv (Block m l) -> [Block m l] -> DFM a (Txlimit, LGraph m l) - rewrite_blocks txlim rewritten [] = return (txlim, G.LGraph eid rewritten) - rewrite_blocks txlim rewritten (G.Block id t : bs) = + -- rewrite_blocks :: + -- OptimizationFuel -> BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel, LGraph m l) + rewrite_blocks fuel rewritten [] = return (fuel, G.LGraph eid rewritten) + rewrite_blocks fuel rewritten (G.Block id t : bs) = do id_fact <- getFact id - first_out <- fc_first_out comp id_fact id txlim + first_out <- fc_first_out comp id_fact id fuel case first_out of - Dataflow a -> propagate txlim (G.ZFirst id) a t rewritten bs - Rewrite fg -> do { markGraphRewritten - ; rewrite_blocks (txlim-1) rewritten - (G.postorder_dfs (labelGraph id fg) ++ bs) } - propagate :: Txlimit -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) -> - [G.Block m l] -> DFM a (Txlimit, G.LGraph m l) - propagate txlim h in' (G.ZTail m t) rewritten bs = + Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs + Rewrite g -> do { markGraphRewritten + ; rewrite_blocks (fuel-1) rewritten + (G.postorder_dfs (labelGraph id g) ++ bs) } + -- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) -> + -- [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l) + propagate fuel h in' (G.ZTail m t) rewritten bs = my_trace "Rewriting middle node" (ppr m) $ - do fc_middle_out comp in' m txlim >>= \x -> case x of - Dataflow a -> propagate txlim (G.ZHead h m) a t rewritten bs + do fc_middle_out comp in' m fuel >>= \x -> case x of + Dataflow a -> propagate fuel (G.ZHead h m) a t rewritten bs Rewrite g -> - my_trace "Rewriting middle node...\n" empty $ - do g <- lgraphOfGraph g - (txlim, a, g) <- solve_and_rewrite_f comp (txlim-1) g in' - markGraphRewritten - my_trace "Rewrite of middle node completed\n" empty $ - let (g', h') = G.splice_head h g in - propagate txlim h' a t (plusUFM (G.gr_blocks g') rewritten) bs - propagate txlim h in' (G.ZLast l) rewritten bs = - do last_outs comp in' l txlim >>= \x -> case x of + do markGraphRewritten + (fuel, a, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in' + let (blocks, h') = G.splice_head' h g + propagate fuel h' a t (blocks `plusUFM` rewritten) bs + propagate fuel h in' (G.ZLast l) rewritten bs = + do last_outs comp in' l fuel >>= \x -> case x of Dataflow outs -> do set_or_save outs let b = G.zip (G.ZBlock h (G.ZLast l)) - rewrite_blocks txlim (G.insertBlock b rewritten) bs + rewrite_blocks fuel (G.insertBlock b rewritten) bs Rewrite g -> - -- could test here that [[exits g = exits (G.Entry, G.ZLast l)]] - {- if Debug.on "rewrite-last" then - Printf.eprintf "ZLast node %s rewritten to:\n" - (RS.rtl (G.last_instr l)); -} - do g <- lgraphOfGraph g - (txlim, _, g) <- solve_and_rewrite_f comp (txlim-1) g in' - markGraphRewritten - let g' = G.splice_head_only h g - rewrite_blocks txlim (plusUFM (G.gr_blocks g') rewritten) bs + do markGraphRewritten + (fuel, _, g) <- solve_and_rewrite_f_graph comp (fuel-1) g in' + let g' = G.splice_head_only' h g + rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs f_rewrite comp entry_fact g = - do { txlim <- liftTx txRemaining - ; (txlim', _, gc) <- solve_and_rewrite_f comp txlim g entry_fact - ; liftTx $ txDecrement (fc_name comp) txlim txlim' + do { fuel <- liftTx txRemaining + ; (fuel', _, gc) <- solve_and_rewrite_f comp fuel g entry_fact + ; liftTx $ txDecrement (fc_name comp) fuel fuel' ; return gc } @@ -761,9 +828,9 @@ let debug s (f, comp) = let setter dir node run_sets set = run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in let rewr node g = pr "%s rewrites %s to \n" comp.name node in - let wrap f nodestring wrap_answer in' node txlim = + let wrap f nodestring wrap_answer in' node fuel = fact "in " (nodestring node) in'; - wrap_answer (nodestring node) (f in' node txlim) + wrap_answer (nodestring node) (f in' node fuel) and wrap_fact n answer = let () = match answer with | Dataflow a -> fact "out" n a @@ -783,41 +850,25 @@ anal_f comp = comp { fc_first_out = wrap2 $ fc_first_out comp , fc_last_outs = wrap2 $ fc_last_outs comp , fc_exit_outs = wrap1 $ fc_exit_outs comp } - where wrap2 f out node _txlim = return $ Dataflow (f out node) - wrap1 f fact _txlim = return $ Dataflow (f fact) + where wrap2 f out node _fuel = return $ Dataflow (f out node) + wrap1 f fact _fuel = return $ Dataflow (f fact) a_t_f anal tx = let answer = answer' liftUSM - first_out in' id txlim = - answer txlim (fc_first_out tx in' id) (fc_first_out anal in' id) - middle_out in' m txlim = - answer txlim (fc_middle_out tx in' m) (fc_middle_out anal in' m) - last_outs in' l txlim = - answer txlim (fc_last_outs tx in' l) (fc_last_outs anal in' l) - exit_outs in' txlim = undefined - answer txlim (fc_exit_outs tx in') (fc_exit_outs anal in') + first_out in' id fuel = + answer fuel (fc_first_out tx in' id) (fc_first_out anal in' id) + middle_out in' m fuel = + answer fuel (fc_middle_out tx in' m) (fc_middle_out anal in' m) + last_outs in' l fuel = + answer fuel (fc_last_outs tx in' l) (fc_last_outs anal in' l) + exit_outs in' fuel = undefined + answer fuel (fc_exit_outs tx in') (fc_exit_outs anal in') in FComp { fc_name = concat [fc_name anal, " and ", fc_name tx] , fc_last_outs = last_outs, fc_middle_out = middle_out , fc_first_out = first_out, fc_exit_outs = exit_outs } -{- Note [Rewriting labelled LGraphs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's hugely annoying that we get in an LGraph and in order to solve it -we have to slap on a new label which we then immediately strip off. -But the alternative is to have all the iterative solvers work on -Graphs, and then suddenly instead of a single case (ZBlock) every -solver has to deal with two cases (ZBlock and ZTail). So until -somebody comes along who is smart enough to do this and still leave -the code understandable for mortals, it stays as it is. - -(A good place to start changing things would be to figure out what is -the analogue of postorder_dfs for Graphs, and to figure out what -higher-order functions would do for dealing with the resulting -sequences of *things*.) --} - f4sep :: [SDoc] -> SDoc f4sep [] = fsep [] f4sep (d:ds) = fsep (d : map (nest 4) ds) @@ -834,3 +885,7 @@ subAnalysis' m = return a } where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) + + +_unused :: FS.FastString +_unused = undefined