Skip to content
GitLab
Commit b9bcf6e7 authored by nr@eecs.harvard.edu's avatar nr@eecs.harvard.edu
Browse files

new signatures for splicing functions, new postorder_dfs

parent 2f48dee3
Hide whitespace changes
Inline Side-by-side
compiler/cmm/ZipCfg.hs
View file @ b9bcf6e7
......@@ -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)
-- , (???, [<blocks>,
-- 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
compiler/cmm/ZipCfgExtras.hs
View file @ b9bcf6e7
......@@ -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 ::
......
compiler/cmm/ZipDataflow.hs
View file @ b9bcf6e7
{-# 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)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment