From: Norman Ramsey Date: Thu, 13 Sep 2007 17:36:53 +0000 (+0000) Subject: new signatures for splicing functions, new postorder_dfs X-Git-Tag: 2007-09-25~80 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=b9bcf6e71abe0d861c99618ee5a7ae9e2c45d26c new signatures for splicing functions, new postorder_dfs --- diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs index 6158435..bf8d49f 100644 --- a/compiler/cmm/ZipCfg.hs +++ b/compiler/cmm/ZipCfg.hs @@ -14,15 +14,15 @@ module ZipCfg -- (open to renaming suggestions here) , blockId, zip, unzip, last, goto_end, zipht, tailOfLast , remove_entry_label - , splice_tail, splice_head, splice_head_only + , splice_tail, splice_head, splice_head_only', splice_head' , of_block_list, to_block_list , map_nodes - , postorder_dfs + , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except , fold_layout , fold_blocks , translate - , pprLgraph + , pprLgraph, pprGraph {- -- the following functions might one day be useful and can be found @@ -150,7 +150,7 @@ data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l) -- | Blocks and flow graphs; see Note [Kinds of graphs] data Block m l = Block BlockId (ZTail m l) -data Graph m l = Graph (ZTail m l) (BlockEnv (Block m l)) +data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) } data LGraph m l = LGraph { lg_entry :: BlockId , lg_blocks :: BlockEnv (Block m l) } @@ -217,15 +217,16 @@ ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l) -- , (???, [, -- N: y:=x; return (y,x)]) -splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m) -splice_tail :: LGraph m l -> ZTail m l -> (ZTail m l, LGraph m l) +splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m) +splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m) +splice_tail :: Graph m l -> ZTail m l -> Graph m l --- | We can also splice a single-entry, no-exit LGraph into a head. +-- | We can also splice a single-entry, no-exit Graph into a head. splice_head_only :: ZHead m -> LGraph m l -> LGraph m l +splice_head_only' :: ZHead m -> Graph m l -> LGraph m l --- | Finally, we can remove the entry label of an LGraph and remove --- it, leaving a Graph: -remove_entry_label :: LGraph m l -> Graph m l + +-- | A safe operation -- | Conversion to and from the environment form is convenient. For -- layout or dataflow, however, one will want to use 'postorder_dfs' @@ -323,6 +324,10 @@ instance LastNode l => HavingSuccessors (ZBlock m l) where instance LastNode l => HavingSuccessors (Block m l) where succs b = succs (unzip b) +instance LastNode l => HavingSuccessors (ZTail m l) where + succs b = succs (lastTail b) + + -- ================ IMPLEMENTATION ================-- @@ -353,9 +358,11 @@ head_id :: ZHead m -> BlockId head_id (ZFirst id) = id head_id (ZHead h _) = head_id h -last (ZBlock _ t) = lastt t - where lastt (ZLast l) = l - lastt (ZTail _ t) = lastt t +last (ZBlock _ t) = lastTail t + +lastTail :: ZTail m l -> ZLast l +lastTail (ZLast l) = l +lastTail (ZTail _ t) = lastTail t tailOfLast l = ZLast (LastOther l) -- ^ tedious to write in every client @@ -398,6 +405,13 @@ single_exit g = foldUFM check 0 (lg_blocks g) == 1 LastExit -> count + (1 :: Int) _ -> count +-- | Used in assertions; tells if a graph has exactly one exit +single_exitg :: Graph l m -> Bool +single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1 + where add block count = count + exit_count (last (unzip block)) + exit_count LastExit = 1 :: Int + exit_count _ = 0 + ------------------ graph traversals -- | This is the most important traversal over this data structure. It drops @@ -420,8 +434,9 @@ single_exit g = foldUFM check 0 (lg_blocks g) == 1 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D. -- Better to geot [A,B,C,D] --- postorder_dfs :: LastNode l => LGraph m l -> [Block m l] -postorder_dfs g@(LGraph _ blocks) = + +postorder_dfs' :: LastNode l => LGraph m l -> [Block m l] +postorder_dfs' g@(LGraph _ blocks) = let FGraph _ eblock _ = entry g in vnode (zip eblock) (\acc _visited -> acc) [] emptyBlockSet where @@ -442,6 +457,39 @@ postorder_dfs g@(LGraph _ blocks) = Just b -> b : rst Nothing -> rst +postorder_dfs g@(LGraph _ blockenv) = + let FGraph id eblock _ = entry g + dfs1 = zip eblock : + postorder_dfs_from_except blockenv eblock (unitUniqSet id) + dfs2 = postorder_dfs' g + in ASSERT (map blockId dfs1 == map blockId dfs2) dfs2 + +postorder_dfs_from + :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l] +postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet + +postorder_dfs_from_except :: forall b m l . (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l] +postorder_dfs_from_except blocks b visited = + vchildren (get_children b) (\acc _visited -> acc) [] visited + where + -- vnode :: + -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a + vnode block@(Block id _) cont acc visited = + if elemBlockSet id visited then + cont acc visited + else + let cont' acc visited = cont (block:acc) visited in + vchildren (get_children block) cont' acc (extendBlockSet visited id) + vchildren bs cont acc visited = + let next children acc visited = + case children of [] -> cont acc visited + (b:bs) -> vnode b (next bs) acc visited + in next bs acc visited + get_children block = foldl add_id [] (succs block) + add_id rst id = case lookupBlockEnv blocks id of + Just b -> b : rst + Nothing -> rst + -- | Slightly more complicated than the usual fold because we want to tell block -- 'b1' what its inline successor is going to be, so that if 'b1' ends with @@ -494,6 +542,22 @@ prepare_for_splicing g single multi = case gl of LastExit -> multi etail gh gblocks _ -> panic "exit is not exit?!" +prepare_for_splicing' :: + Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a) + -> a +prepare_for_splicing' (Graph etail gblocks) single multi = + if isNullUFM gblocks then + case lastTail etail of + LastExit -> single etail + _ -> panic "bad single block" + else + case splitp_blocks is_exit gblocks of + Nothing -> panic "Can't find an exit block" + Just (gexit, gblocks) -> + let (gh, gl) = goto_end $ unzip gexit in + case gl of LastExit -> multi etail gh gblocks + _ -> panic "exit is not exit?!" + is_exit :: Block m l -> Bool is_exit b = case last (unzip b) of { LastExit -> True; _ -> False } @@ -507,8 +571,28 @@ splice_head head g = splice_many_blocks entry exit others = (LGraph eid (insertBlock (zipht head entry) others), exit) +splice_head' head g = + ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks + where splice_one_block tail' = + case ht_to_last head tail' of + (head, LastExit) -> (emptyBlockEnv, head) + _ -> panic "spliced LGraph without exit" + splice_many_blocks entry exit others = + (insertBlock (zipht head entry) others, exit) + +-- splice_tail :: Graph m l -> ZTail m l -> Graph m l splice_tail g tail = - ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks + ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks + where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv + append_tails (ZLast LastExit) tail = tail + append_tails (ZLast _) _ = panic "spliced single block without LastExit" + append_tails (ZTail m t) tail = ZTail m (append_tails t tail) + splice_many_blocks entry exit others = + Graph entry (insertBlock (zipht exit tail) others) + +{- +splice_tail g tail = + AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks where splice_one_block tail' = -- return tail' .. tail case ht_to_last (ZFirst (lg_entry g)) tail' of (head', LastExit) -> @@ -518,6 +602,7 @@ splice_tail g tail = _ -> panic "spliced single block without Exit" splice_many_blocks entry exit others = (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others)) +-} splice_head_only head g = let FGraph eid gentry gblocks = entry g @@ -525,12 +610,10 @@ splice_head_only head g = ZBlock (ZFirst _) tail -> LGraph eid (insertBlock (zipht head tail) gblocks) _ -> panic "entry not at start of block?!" -remove_entry_label g = - let FGraph e eblock others = entry g - in case eblock of - ZBlock (ZFirst id) tail - | id == e -> Graph tail others - _ -> panic "id doesn't match on entry block" +splice_head_only' head (Graph tail gblocks) = + let eblock = zipht head tail in + LGraph (blockId eblock) (insertBlock eblock gblocks) + --- Translation @@ -619,5 +702,11 @@ pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}" where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail blocks = postorder_dfs g +pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc +pprGraph (Graph tail blockenv) = + text "{" $$ nest 2 (ppr tail $$ (vcat $ map pprBlock blocks)) $$ text "}" + where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail + blocks = postorder_dfs_from blockenv tail + _unused :: FS.FastString _unused = undefined diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs index e4bd1ae..787a58a 100644 --- a/compiler/cmm/ZipCfgExtras.hs +++ b/compiler/cmm/ZipCfgExtras.hs @@ -16,8 +16,6 @@ import Maybes import Panic import ZipCfg -import UniqFM - import Prelude hiding (zip, unzip, last) @@ -31,12 +29,14 @@ unfocus :: FGraph m l -> LGraph m l -- lose focus -- the current focus. -- The new focus can be at either the entry edge or the exit edge. +{- splice_focus_entry :: FGraph m l -> LGraph m l -> FGraph m l splice_focus_exit :: FGraph m l -> LGraph m l -> FGraph m l +-} _unused :: () _unused = all `seq` () - where all = ( exit, focusp, unfocus, splice_focus_entry, splice_focus_exit + where all = ( exit, focusp, unfocus {- , splice_focus_entry, splice_focus_exit -} , fold_fwd_block, foldM_fwd_block (\_ a -> Just a) ) @@ -49,6 +49,8 @@ exit g@(LGraph eid _) = FGraph eid (ZBlock h (ZLast l)) others where FGraph _ b others = focusp is_exit g `orElse` panic "no exit in flow graph" (h, l) = goto_end b + +{- splice_focus_entry (FGraph eid (ZBlock head tail) blocks) g = let (tail', g') = splice_tail g tail in FGraph eid (ZBlock head tail') (plusUFM (lg_blocks g') blocks) @@ -56,6 +58,7 @@ splice_focus_entry (FGraph eid (ZBlock head tail) blocks) g = splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g = let (g', head') = splice_head head g in FGraph eid (ZBlock head' tail) (plusUFM (lg_blocks g') blocks) +-} -- | Fold from first to last fold_fwd_block :: diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index 535b041..c09a57e 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE MultiParamTypeClasses #-} module ZipDataflow ( Answer(..) @@ -368,9 +367,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,15 +379,14 @@ 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 @@ -402,6 +399,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 +414,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 +438,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 @@ -450,49 +467,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 -- 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) -- These blocks have been rewritten - -- -> 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.lg_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.lg_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 @@ -643,18 +673,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 @@ -662,13 +690,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 } {- @@ -691,6 +724,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 -> @@ -715,9 +757,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 = @@ -725,13 +767,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.lg_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 -> @@ -739,15 +778,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.lg_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 @@ -807,22 +841,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)