-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-}
+
+{-# LANGUAGE MultiParamTypeClasses #-}
module ZipDataflow
( Answer(..)
, BComputation(..), BAnalysis, BTransformation, BFunctionalTransformation
-- | 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
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) =>
-- 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 -> OptimizationFuel -> G.LGraph m l -> a -> DFM a (OptimizationFuel, a)
+ (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 -> OptimizationFuel -> G.LGraph m l -> DFM a (OptimizationFuel, a)
+ -- 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
+ 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
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) }
-}
solve_and_rewrite_b ::
- forall m l a. (DebugNodes m l, Outputable a) =>
- BPass m l a -> OptimizationFuel -> LGraph m l -> a -> DFM a (OptimizationFuel, 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 comp fuel graph exit_fact =
do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1
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 ::
- BPass m l a -> OptimizationFuel ->
- BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel,G.LGraph m l)
+ -- 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 =
; -- continue at entry of g
propagate fuel h a t rewritten'
}
- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l ->
- BlockEnv (Block m l) -> DFM a (OptimizationFuel, G.LGraph m l)
+ -- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l ->
+ -- BlockEnv (Block m l) -> 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
; (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
+ ; 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' }
propagate fuel h@(G.ZFirst id) out tail rewritten =
; (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
+ ; 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' }
in rewrite_next_block fuel
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
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 "<entry>" else show id
+ _blockname = if id == G.lg_entry graph then "<entry>" 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
-- | 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 -> OptimizationFuel -> G.LGraph m l -> a ->
- DFM a (OptimizationFuel, a, LastOutFacts a)
+ (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"
; fuel <- general_forward (comp_with_exit_f comp exit_fact_id) fuel in_fact g
; forgetFact exit_fact_id -- close space leak
; return (fuel, a, LastOutFacts outs) }
where
- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel
+ -- 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 fuel b =
let set_tail_facts fuel in' (G.ZTail m t) =
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 -> OptimizationFuel -> LGraph m l -> a -> DFM a (OptimizationFuel, a, LGraph m l)
+ (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"
return (fuel, exit_fact, g)
forward_rewrite ::
- forall m l a . (DebugNodes m l, Outputable a) =>
- FPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> DFM a (OptimizationFuel, G.LGraph m l)
+ (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 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 ::
- OptimizationFuel -> BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel, LGraph m l)
+ -- 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
Rewrite fg -> do { markGraphRewritten
; rewrite_blocks (fuel-1) rewritten
(G.postorder_dfs (labelGraph id fg) ++ 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 :: 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 fuel >>= \x -> case x of
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
+ propagate fuel h' a t (plusUFM (G.lg_blocks g') rewritten) bs
propagate fuel h in' (G.ZLast l) rewritten bs =
do last_outs comp in' l fuel >>= \x -> case x of
Dataflow outs ->
(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
+ rewrite_blocks fuel (plusUFM (G.lg_blocks g') rewritten) bs
f_rewrite comp entry_fact g =
do { fuel <- liftTx txRemaining
projects / ghc-hetmet.git / blobdiff