module ZipDataflow
( DebugNodes(), RewritingDepth(..), LastOutFacts(..)
, zdfSolveFrom, zdfRewriteFrom
+ , zdfSolveFromL
, ForwardTransfers(..), BackwardTransfers(..)
, ForwardRewrites(..), BackwardRewrites(..)
, ForwardFixedPoint, BackwardFixedPoint
, zdfDecoratedGraph -- not yet implemented
, zdfFpContents
, zdfFpLastOuts
+ , zdfBRewriteFromL, zdfFRewriteFromL
)
where
import BlockId
import CmmTx
import DFMonad
+import OptimizationFuel as F
import MkZipCfg
import ZipCfg
import qualified ZipCfg as G
import Maybes
import Outputable
import Panic
-import UniqFM
import Control.Monad
import Maybe
-- | A backward rewrite takes the same inputs as a backward transfer,
-- but instead of producing a fact, it produces a replacement graph or Nothing.
--- The type of the replacement graph is given as a type parameter 'g'
--- of kind * -> * -> *. This design offers great flexibility to clients,
--- but it might be worth simplifying this module by replacing this type
--- parameter with AGraph everywhere (SLPJ 19 May 2008).
data BackwardRewrites middle last a = BackwardRewrites
{ br_first :: a -> BlockId -> Maybe (AGraph middle last)
type PassName = String
--- | zdfSolveFrom is an overloaded name that resolves to a pure
+-- | 'zdfSolveFrom' is an overloaded name that resolves to a pure
-- analysis with no rewriting. It has only two instances: forward and
-- backward. Since it needs no rewrites, the type parameters of the
-- class are transfer functions and the fixed point.
--
-- The intent of the rest of the type signature should be obvious.
-- If not, place a skype call to norman-ramsey or complain bitterly
--- to norman-ramsey@acm.org.
+-- to <norman-ramsey@acm.org>.
class DataflowSolverDirection transfers fixedpt where
zdfSolveFrom :: (DebugNodes m l, Outputable a)
+ => BlockEnv a -- ^ Initial facts (unbound == bottom)
+ -> PassName
+ -> DataflowLattice a -- ^ Lattice
+ -> transfers m l a -- ^ Dataflow transfer functions
+ -> a -- ^ Fact flowing in (at entry or exit)
+ -> Graph m l -- ^ Graph to be analyzed
+ -> FuelMonad (fixedpt m l a ()) -- ^ Answers
+ zdfSolveFromL :: (DebugNodes m l, Outputable a)
=> BlockEnv a -- Initial facts (unbound == bottom)
-> PassName
-> DataflowLattice a -- Lattice
-> transfers m l a -- Dataflow transfer functions
-> a -- Fact flowing in (at entry or exit)
- -> Graph m l -- Graph to be analyzed
+ -> LGraph m l -- Graph to be analyzed
-> FuelMonad (fixedpt m l a ()) -- Answers
+ zdfSolveFromL b p l t a g = zdfSolveFrom b p l t a $ quickGraph g
-- There are exactly two instances: forward and backward
instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint
-> Graph m l
-> FuelMonad (fixedpt m l a (Graph m l))
+-- Temporarily lifting from Graph to LGraph -- an experiment to see how we
+-- can eliminate some hysteresis between Graph and LGraph.
+-- Perhaps Graph should be confined to dataflow code.
+-- Trading space for time
+quickGraph :: LastNode l => LGraph m l -> Graph m l
+quickGraph g = Graph (ZLast $ mkBranchNode $ lg_entry g) $ lg_blocks g
+
+quickLGraph :: LastNode l => Int -> Graph m l -> FuelMonad (LGraph m l)
+quickLGraph args (Graph (ZLast (LastOther l)) blockenv)
+ | isBranchNode l = return $ LGraph (branchNodeTarget l) args blockenv
+quickLGraph args g = F.lGraphOfGraph g args
+
+fixptWithLGraph :: LastNode l => Int -> CommonFixedPoint m l fact (Graph m l) ->
+ FuelMonad (CommonFixedPoint m l fact (LGraph m l))
+fixptWithLGraph args cfp =
+ do fp_c <- quickLGraph args $ fp_contents cfp
+ return $ cfp {fp_contents = fp_c}
+
+ffixptWithLGraph :: LastNode l => Int -> ForwardFixedPoint m l fact (Graph m l) ->
+ FuelMonad (ForwardFixedPoint m l fact (LGraph m l))
+ffixptWithLGraph args fp =
+ do common <- fixptWithLGraph args $ ffp_common fp
+ return $ fp {ffp_common = common}
+
+zdfFRewriteFromL :: (DebugNodes m l, Outputable a)
+ => RewritingDepth -- whether to rewrite a rewritten graph
+ -> BlockEnv a -- initial facts (unbound == botton)
+ -> PassName
+ -> DataflowLattice a
+ -> ForwardTransfers m l a
+ -> ForwardRewrites m l a
+ -> a -- fact flowing in (at entry or exit)
+ -> LGraph m l
+ -> FuelMonad (ForwardFixedPoint m l a (LGraph m l))
+zdfFRewriteFromL d b p l t r a g@(LGraph _ args _) =
+ do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
+ ffixptWithLGraph args fp
+
+zdfBRewriteFromL :: (DebugNodes m l, Outputable a)
+ => RewritingDepth -- whether to rewrite a rewritten graph
+ -> BlockEnv a -- initial facts (unbound == botton)
+ -> PassName
+ -> DataflowLattice a
+ -> BackwardTransfers m l a
+ -> BackwardRewrites m l a
+ -> a -- fact flowing in (at entry or exit)
+ -> LGraph m l
+ -> FuelMonad (BackwardFixedPoint m l a (LGraph m l))
+zdfBRewriteFromL d b p l t r a g@(LGraph _ args _) =
+ do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
+ fixptWithLGraph args fp
+
+
data RewritingDepth = RewriteShallow | RewriteDeep
-- When a transformation proposes to rewrite a node,
-- you can either ask the system to
areturn :: AGraph m l -> DFM a (Graph m l)
areturn g = liftToDFM $ liftUniq $ graphOfAGraph g
-
-{-
-graphToLGraph :: LastNode l => Graph m l -> DFM a (LGraph m l)
-graphToLGraph (Graph (ZLast (LastOther l)) blockenv)
- | isBranchNode l = return $ LGraph (branchNodeTarget l) blockenv
-graphToLGraph (Graph tail blockenv) =
- do id <- freshBlockId "temporary entry label"
- return $ LGraph id $ insertBlock (Block id tail) blockenv
--}
-
-- | Here we prefer not simply to slap on 'goto eid' because this
-- introduces an unnecessary basic block at each rewrite, and we don't
-- want to stress out the finite map more than necessary
lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
-lgraphToGraph (LGraph eid blocks) =
- if flip any (eltsUFM blocks) $ \block -> any (== eid) (succs block) then
+lgraphToGraph (LGraph eid _ blocks) =
+ if flip any (eltsBlockEnv blocks) $ \block -> any (== eid) (succs block) then
Graph (ZLast (mkBranchNode eid)) blocks
else -- common case: entry is not a branch target
- let Block _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
- in Graph entry (delFromUFM blocks eid)
+ let Block _ _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
+ in Graph entry (delFromBlockEnv blocks eid)
class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
fwd_pure_anal name env transfers in_fact g =
do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
return fp
- where -- definitiely a case of "I love lazy evaluation"
+ where -- definitely a case of "I love lazy evaluation"
anal_f = forward_sol (\_ _ -> Nothing) panic_depth
panic_rewrites = panic "pure analysis asked for a rewrite function"
panic_fuel = panic "pure analysis asked for fuel"
solve finish in_fact (Graph entry blockenv) fuel =
let blocks = G.postorder_dfs_from blockenv entry
set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv)
- set_successor_facts (Block id tail) fuel =
+ set_successor_facts (Block id _ tail) fuel =
do { idfact <- getFact id
; (last_outs, fuel) <-
case check_maybe fuel $ fr_first rewrites idfact id of
in do { solve depth name start transfers rewrites in_fact g fuel
; eid <- freshBlockId "temporary entry id"
; (rewritten, fuel) <-
- rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
+ rew_tail (ZFirst eid emptyStackInfo)
+ in_fact entry emptyBlockEnv fuel
; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
; a <- finish
- ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
+ ; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel)
}
don't_rewrite facts finish in_fact g fuel =
do { solve depth name facts transfers rewrites in_fact g fuel
rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
-> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
- rewrite_blocks (G.Block id t : bs) rewritten fuel =
- do let h = ZFirst id
+ rewrite_blocks (G.Block id off t : bs) rewritten fuel =
+ do let h = ZFirst id off
a <- getFact id
case check_maybe fuel $ fr_first rewrites a id of
Nothing -> do { (rewritten, fuel) <-
Just g -> do { markGraphRewritten
; g <- areturn g
; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
- ; let (blocks, h) = splice_head' (ZFirst id) g
+ ; let (blocks, h) = splice_head' h g
; (rewritten, fuel) <-
- rew_tail h outfact t (blocks `plusUFM` rewritten) fuel
+ rew_tail h outfact t (blocks `plusBlockEnv` rewritten) fuel
; rewrite_blocks bs rewritten fuel }
rew_tail head in' (G.ZTail m t) rewritten fuel =
; g <- areturn g
; (a, g, fuel) <- inner_rew getExitFact in' g fuel
; let (blocks, h) = G.splice_head' head g
- ; rew_tail h a t (blocks `plusUFM` rewritten) fuel
+ ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel
}
rew_tail h in' (G.ZLast l) rewritten fuel =
my_trace "Rewriting last node" (ppr l) $
; g <- areturn g
; ((), g, fuel) <- inner_rew (return ()) in' g fuel
; let g' = G.splice_head_only' h g
- ; return (G.lg_blocks g' `plusUFM` rewritten, fuel)
+ ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel)
}
either_last rewrites in' (LastExit) = fr_exit rewrites in'
either_last rewrites in' (LastOther l) = fr_last rewrites in' l
; (a, fuel) <-
case check_maybe fuel $ last_rew env l of
Nothing -> return (last_in env l, fuel)
- Just g -> subsolve g exit_fact fuel
+ Just g -> do g' <- areturn g
+ my_trace "analysis rewrites last node"
+ (ppr l <+> pprGraph g') $
+ subsolve g exit_fact fuel
; set_head_fact h a fuel
; return fuel }
in do { fuel <- run "backward" name set_block_fact blocks fuel
; eid <- freshBlockId "temporary entry id"
- ; fuel <- set_block_fact (Block eid entry) fuel
+ ; fuel <- set_block_fact (Block eid emptyStackInfo entry) fuel
; a <- getFact eid
; forgetFact eid
; return (a, fuel)
}
- set_head_fact (G.ZFirst id) a fuel =
+ set_head_fact (G.ZFirst id _) a fuel =
case check_maybe fuel $ br_first rewrites a id of
- Nothing -> do { my_trace "set_head_fact" (ppr id) $
+ Nothing -> do { my_trace "set_head_fact" (ppr id <+> text "=" <+>
+ ppr (bt_first_in transfers a id)) $
setFact id $ bt_first_in transfers a id
; return fuel }
- Just g -> do { (a, fuel) <- subsolve g a fuel
- ; setFact id a
+ Just g -> do { g' <- areturn g
+ ; (a, fuel) <- my_trace "analysis rewrites first node"
+ (ppr id <+> pprGraph g') $
+ subsolve g a fuel
+ ; setFact id $ bt_first_in transfers a id
; return fuel
}
set_head_fact (G.ZHead h m) a fuel =
case check_maybe fuel $ br_middle rewrites a m of
Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel
- Just g -> do { (a, fuel) <- subsolve g a fuel
+ Just g -> do { g' <- areturn g
+ ; (a, fuel) <- my_trace "analysis rewrites middle node"
+ (ppr m <+> pprGraph g') $
+ subsolve g a fuel
; set_head_fact h a fuel }
fixed_point g exit_fact fuel =
rewrite start g exit_fact fuel =
let Graph entry blockenv = g
blocks = reverse $ G.postorder_dfs_from blockenv entry
- in do { solve depth name start transfers rewrites g exit_fact fuel
- ; env <- getAllFacts
- ; my_trace "facts after solving" (ppr env) $ return ()
+ in do { (FP env in_fact _ _ _, _) <- -- don't drop the entry fact!
+ solve depth name start transfers rewrites g exit_fact fuel
+ --; env <- getAllFacts
+ -- ; my_trace "facts after solving" (ppr env) $ return ()
; eid <- freshBlockId "temporary entry id"
; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel
-- We can't have the fact check fail on the bogus entry, which _may_ change
- ; (rewritten, fuel) <- rewrite_blocks False [Block eid entry] rewritten fuel
- ; a <- getFact eid
- ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
- }
+ ; (rewritten, fuel) <-
+ rewrite_blocks False [Block eid emptyStackInfo entry]
+ rewritten fuel
+ ; my_trace "eid" (ppr eid) $ return ()
+ ; my_trace "exit_fact" (ppr exit_fact) $ return ()
+ ; my_trace "in_fact" (ppr in_fact) $ return ()
+ ; return (in_fact, lgraphToGraph (LGraph eid 0 rewritten), fuel)
+ } -- Remember: the entry fact computed by @solve@ accounts for rewriting
don't_rewrite facts g exit_fact fuel =
do { (fp, _) <-
solve depth name facts transfers rewrites g exit_fact fuel
; g <- areturn g
; (a, g, fuel) <- inner_rew g exit_fact fuel
; let G.Graph t new_blocks = g
- ; let rewritten' = new_blocks `plusUFM` rewritten
+ ; let rewritten' = new_blocks `plusBlockEnv` rewritten
; propagate check fuel h a t rewritten' -- continue at entry of g
}
either_last _env (LastExit) = br_exit rewrites
return ()
; (a, g, fuel) <- inner_rew g a fuel
; let Graph t newblocks = G.splice_tail g tail
- ; propagate check fuel h a t (newblocks `plusUFM` rewritten) }
- propagate check fuel (ZFirst id) a tail rewritten =
+ ; my_trace "propagating facts" (ppr a) $
+ propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) }
+ propagate check fuel (ZFirst id off) a tail rewritten =
case maybeRewriteWithFuel fuel $ br_first rewrites a id of
- Nothing -> do { if check then checkFactMatch id $ bt_first_in transfers a id
+ Nothing -> do { if check then
+ checkFactMatch id $ bt_first_in transfers a id
else return ()
- ; return (insertBlock (Block id tail) rewritten, fuel) }
+ ; return (insertBlock (Block id off tail) rewritten, fuel) }
Just g ->
do { markGraphRewritten
; g <- areturn g
; my_trace "Rewrote first node"
(f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
; (a, g, fuel) <- inner_rew g a fuel
- ; if check then checkFactMatch id a else return ()
+ ; if check then checkFactMatch id (bt_first_in transfers a id)
+ else return ()
; let Graph t newblocks = G.splice_tail g tail
- ; let r = insertBlock (Block id t) (newblocks `plusUFM` rewritten)
+ ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten)
; return (r, fuel) }
in fixed_pt_and_fuel
where
-- N.B. Each iteration starts with the same transaction limit;
-- only the rewrites in the final iteration actually count
- trace_block b block =
- my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $
- do_block block b
+ trace_block (b, cnt) block =
+ do b' <- my_trace "about to do" (text name <+> text "on" <+>
+ ppr (blockId block) <+> ppr cnt) $
+ do_block block b
+ return (b', cnt + 1)
iterate n =
do { markFactsUnchanged
- ; b <- foldM trace_block b blocks
+ ; (b, _) <-
+ my_trace "block count:" (ppr (length blocks)) $
+ foldM trace_block (b, 0 :: Int) blocks
; changed <- factsStatus
; facts <- getAllFacts
; let depth = 0 -- was nesting depth
unchanged depth =
my_nest depth (text "facts for" <+> graphId <+> text "are unchanged")
- graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
+ graphId = case blocks of { Block id _ _ : _ -> ppr id ; [] -> text "<empty>" }
show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
- pprBlock (Block id t) = nest 2 (pprFact (id, t))
+ pprBlock (Block id off t) = nest 2 (pprFact' (id, off, t))
pprFacts depth n env =
my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
- (nest 2 $ vcat $ map pprFact $ ufmToList env))
- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
+ (nest 2 $ vcat $ map pprFact $ blockEnvToList env))
+ pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
+ pprFact' (id, off, a) = hang (ppr id <> parens (ppr off) <> colon) 4 (ppr a)
f4sep :: [SDoc] -> SDoc
subAnalysis' m =
do { a <- subAnalysis $
do { a <- m; facts <- getAllFacts
- ; my_trace "after sub-analysis facts are" (pprFacts facts) $
+ ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $
return a }
; facts <- getAllFacts
- ; my_trace "in parent analysis facts are" (pprFacts facts) $
+ ; -- my_trace "in parent analysis facts are" (pprFacts facts) $
return a }
- where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
+ where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
projects / ghc-hetmet.git / blobdiff