X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipDataflow.hs;h=2087b9ce345e98b43bdd8fe98e1c0d576a5422c8;hb=bd2264ad7b4346782efbb5bb786686ec265a5e90;hp=2ce7a25eb95c7463b54e8bfd86987b6a30e10b02;hpb=c0a5a5d2e41341046aaf37c1d2155372e7ed3ee8;p=ghc-hetmet.git diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index 2ce7a25..2087b9c 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} {-# LANGUAGE MultiParamTypeClasses #-} module ZipDataflow ( Answer(..) @@ -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 -[[fuel]] 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 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} @@ -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 @@ -368,9 +395,8 @@ solve_graph_b comp fuel graph exit_fact = Dataflow a -> head_in fuel h a Rewrite g -> do { bot <- botFact - ; g <- lgraphOfGraph g ; (fuel, a) <- subAnalysis' $ - solve_graph_b comp (fuel-1) g bot + 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) $ @@ -381,19 +407,18 @@ solve_graph_b comp fuel graph exit_fact = bc_middle_in comp out m fuel >>= \x -> case x of Dataflow a -> head_in fuel h a Rewrite g -> - do { g <- lgraphOfGraph g - ; (fuel, a) <- subAnalysis' $ solve_graph_b comp (fuel-1) g out - ; my_trace "Rewrote middle node" (f4sep [ppr m, text "to", ppr g]) $ + 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 { g <- lgraphOfGraph g - ; subAnalysis' $ solve_graph_b comp (fuel-1) g out } + 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.gr_entry graph) + ; a <- getFact (G.lg_entry graph) ; facts <- allFacts ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $ return (fuel, a) } @@ -402,6 +427,12 @@ solve_graph_b comp fuel graph exit_fact = 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 @@ -425,6 +466,10 @@ The tail is in final form; the head is still to be rewritten. solve_and_rewrite_b :: (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 fuel graph exit_fact = do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1 @@ -438,7 +483,7 @@ solve_and_rewrite_b comp fuel graph exit_fact = 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 + eid = G.lg_entry graph backward_rewrite comp fuel graph = rewrite_blocks comp fuel emptyBlockEnv $ reverse (G.postorder_dfs graph) -- rewrite_blocks :: @@ -450,45 +495,62 @@ solve_and_rewrite_b comp fuel graph exit_fact = let (h, l) = G.goto_end (G.unzip b) in factsEnv >>= \env -> last_in comp env l fuel >>= \x -> case x of Dataflow a -> propagate fuel h a (G.ZLast l) rewritten - Rewrite g -> -- see Note [Rewriting labelled LGraphs] - do { bot <- botFact - ; g <- lgraphOfGraph g - ; (fuel, a, g') <- solve_and_rewrite_b comp (fuel-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 fuel h a t 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 :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> - -- BlockEnv (Block m l) -> DFM a (OptimizationFuel, G.LGraph m l) + -- 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 - ; (fuel, a, g') <- solve_and_rewrite_b comp (fuel-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 fuel h a t rewritten' } + 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 fuel (extendBlockEnv rewritten id b) bs } - Rewrite fg -> - do { g <- lgraphOfGraph fg - ; (fuel, a, g') <- solve_and_rewrite_b comp (fuel-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 fuel h a t rewritten' } + 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 { fuel <- liftTx txRemaining ; bot <- botFact @@ -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 @@ -626,12 +688,12 @@ solve_graph_f comp fuel g in_fact = -- 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 + 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 fuel b = let set_tail_facts fuel in' (G.ZTail m t) = @@ -639,18 +701,16 @@ solve_graph_f comp fuel g in_fact = 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 - (fuel, out, last_outs) <- subAnalysis' $ - solve_graph_f comp (fuel-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 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 - (fuel, _, last_outs) <- subAnalysis' $ - solve_graph_f comp (fuel-1) g in' + do (fuel, _, last_outs) <- + subAnalysis' $ solve_graph_f_g comp (fuel-1) g in' set_or_save last_outs return fuel G.Block id t = b @@ -658,13 +718,18 @@ solve_graph_f comp fuel g in_fact = 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 - (fuel, out, last_outs) <- subAnalysis' $ - solve_graph_f comp (fuel-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 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 } {- @@ -687,6 +752,15 @@ solve_and_rewrite_f comp fuel graph in_fact = exit_fact <- getFact exit_id 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 :: (DebugNodes m l, Outputable a) => FPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> @@ -695,8 +769,8 @@ forward_rewrite comp fuel graph entry_fact = do setFact eid entry_fact rewrite_blocks fuel emptyBlockEnv (G.postorder_dfs graph) where - eid = G.gr_entry graph - is_local id = isJust $ lookupBlockEnv (G.gr_blocks graph) id + 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) = @@ -711,9 +785,9 @@ forward_rewrite comp fuel graph entry_fact = first_out <- fc_first_out comp id_fact id fuel case first_out of Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs - Rewrite fg -> do { markGraphRewritten + Rewrite g -> do { markGraphRewritten ; rewrite_blocks (fuel-1) rewritten - (G.postorder_dfs (labelGraph id fg) ++ bs) } + (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 = @@ -721,13 +795,10 @@ forward_rewrite comp fuel graph entry_fact = 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 - (fuel, a, g) <- solve_and_rewrite_f comp (fuel-1) g in' - markGraphRewritten - my_trace "Rewrite of middle node completed\n" empty $ - let (g', h') = G.splice_head h g in - propagate fuel h' a t (plusUFM (G.gr_blocks g') rewritten) bs + 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 -> @@ -735,15 +806,10 @@ forward_rewrite comp fuel graph entry_fact = let b = G.zip (G.ZBlock h (G.ZLast l)) 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 - (fuel, _, g) <- solve_and_rewrite_f comp (fuel-1) g in' - markGraphRewritten - let g' = G.splice_head_only h g - rewrite_blocks fuel (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 { fuel <- liftTx txRemaining @@ -803,22 +869,6 @@ a_t_f anal tx = , 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) @@ -835,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