{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, KindSignatures, FlexibleContexts, GADTs #-}
module ZDF5ex
( DebugNodes(), RewritingDepth(..), LastOutFacts(..)
, zdfSolveFrom, zdfRewriteFrom
, ForwardTransfers(..), BackwardTransfers(..)
, ForwardRewrites(..), BackwardRewrites(..)
, ForwardFixedPoint, BackwardFixedPoint
, zdfFpFacts
, zdfFpOutputFact
, zdfGraphChanged
, zdfDecoratedGraph -- not yet implemented
, zdfFpContents
, zdfFpLastOuts
, FuelMonad, liftUniq -- re-export from OptimizationFuel
, DataflowPass(..)
)
where
#include "HsVersions.h"
import BlockId
import CmmTx
import DFLattice
import DFMonad2
import OptimizationFuel as F
import ZipGFex
import UniqSupply -- temporary
import Outputable
import Panic
import Control.Monad
import Maybe
{-
This module implements two useful tools:
1. An iterative solver for dataflow problems
2. The combined dataflow-analysis-and-transformation framework
described by Lerner, Grove, and Chambers in their excellent
2002 POPL paper (http://tinyurl.com/3zycbr or
http://tinyurl.com/3pnscd).
Each tool comes in two flavors: one for forward dataflow problems
and one for backward dataflow problems.
We quote the paper above:
Dataflow analyses can have mutually beneficial interactions.
Previous efforts to exploit these interactions have either
(1) iteratively performed each individual analysis until no
further improvements are discovered or (2) developed "super-
analyses" that manually combine conceptually separate anal-
yses. We have devised a new approach that allows anal-
yses to be defined independently while still enabling them
to be combined automatically and profitably. Our approach
avoids the loss of precision associated with iterating indi-
vidual analyses and the implementation difficulties of man-
ually writing a super-analysis.
The key idea is to provide at each CFG node not only a dataflow
transfer function but also a rewriting function that has the option to
replace the node with a new (possibly empty) graph. The rewriting
function takes a dataflow fact as input, and the fact is used to
justify any rewriting. For example, in a backward problem, the fact
that variable x is dead can be used to justify rewriting node
x := e
to the empty graph. In a forward problem, the fact that x == 7 can
be used to justify rewriting node
y := x + 1
to
y := 8
which in turn will be analyzed and produce a new fact:
x == 7 and y == 8.
In its most general form, this module takes as input graph, transfer
equations, rewrites, and an initial set of dataflow facts, and
iteratively computes a new graph and a new set of dataflow facts such
that
* The set of facts is a fixed point of the transfer equations
* The graph has been rewritten as much as is consistent with
the given facts and requested rewriting depth (see below)
N.B. 'A set of facts' is shorthand for 'A finite map from CFG label to fact'.
The types of transfer equations, rewrites, and fixed points are
different for forward and backward problems. To avoid cluttering the
name space with two versions of every names, other names such as
zdfSolveFrom are overloaded to work in both forward or backward
directions. This design decision is based on experience with the
predecessor module, now called ZipDataflow0 and destined for the bit bucket.
This module is deliberately very abstract. It is a completely general
framework and well-nigh impossible to understand in isolation. The
cautious reader will begin with some concrete examples in the form of
clients. NR recommends
CmmLiveZ A simple liveness analysis
CmmSpillReload.removeDeadAssignmentsAndReloads
A piece of spaghetti to pull on, which leads to
- a two-part liveness analysis that tracks
variables live in registers and live on the stack
- elimination of assignments to dead variables
- elimination of redundant reloads
Even hearty souls should avoid the CmmProcPointZ client, at least for
the time being.
-}
{- ============ TRANSFER FUNCTIONS AND REWRITES =========== -}
-- | For a backward transfer, you're given the fact on a node's
-- outedge and you compute the fact on the inedge. Facts have type 'a'.
-- A last node may have multiple outedges, each pointing to a labelled
-- block, so instead of a fact it is given a mapping from BlockId to fact.
data BackwardTransfers middle last a = BackwardTransfers
{ bt_first_in :: BlockId -> a -> a
, bt_middle_in :: middle -> a -> a
, bt_last_in :: last -> (BlockId -> a) -> a
}
-- | For a forward transfer, you're given the fact on a node's
-- inedge and you compute the fact on the outedge. Because a last node
-- may have multiple outedges, each pointing to a labelled
-- block, so instead of a fact it produces a list of (BlockId, fact) pairs.
data ForwardTransfers middle last a = ForwardTransfers
{ ft_first_out :: BlockId -> a -> a
, ft_middle_out :: middle -> a -> a
, ft_last_outs :: last -> a -> LastOutFacts a
}
newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
-- ^ These are facts flowing out of a last node to the node's successors.
-- They are either to be set (if they pertain to the graph currently
-- under analysis) or propagated out of a sub-analysis
-- | A backward rewrite takes the same inputs as a backward transfer,
-- but instead of producing a fact, it produces a replacement graph or Nothing.
type O = ZOpen
type C = ZClosed
data BackwardRewrites middle last a = BackwardRewrites
{ br_first :: BlockId -> a -> Maybe (ZipGF' middle last C O)
, br_middle :: middle -> a -> Maybe (ZipGF' middle last O O)
, br_last :: last -> (BlockId -> a) -> Maybe (ZipGF' middle last O C)
, br_entry :: Maybe (ZipGF' middle last O O)
}
-- | A forward rewrite takes the same inputs as a forward transfer,
-- but instead of producing a fact, it produces a replacement graph or Nothing.
data ForwardRewrites middle last a = ForwardRewrites
{ fr_first :: BlockId -> a -> Maybe (ZipGF' middle last C O)
, fr_middle :: middle -> a -> Maybe (ZipGF' middle last O O)
, fr_last :: last -> a -> Maybe (ZipGF' middle last O C)
, fr_exit :: a -> Maybe (ZipGF' middle last O O)
}
type ZipGF' m l e x = UniqSM (ZipGF m l e x) -- simulate monadic goo for now
{- ===================== A DATAFLOW PASS =================== -}
data DataflowPass transfers rewrites m l a
= DataflowPass { dfp_lattice :: DataflowLattice a
, dfp_transfers :: transfers m l a
, dfp_rewrites :: rewrites m l a
}
{- ===================== FIXED POINTS =================== -}
-- | The result of combined analysis and transformation is a
-- solution to the set of dataflow equations together with a 'contained value'.
-- This solution is a member of type class 'FixedPoint', which is parameterized by
-- * middle and last nodes 'm' and 'l'
-- * data flow fact 'fact'
-- * the type 'a' of the contained value
--
-- In practice, the contained value 'zdfFpContents' is either a
-- rewritten graph, when rewriting, or (), when solving without
-- rewriting. A function 'zdfFpMap' allows a client to change
-- the contents without changing other values.
--
-- To save space, we provide the solution 'zdfFpFacts' as a mapping
-- from BlockId to fact; if necessary, facts on edges can be
-- reconstructed using the transfer functions; this functionality is
-- intended to be included as the 'zdfDecoratedGraph', but the code
-- has not yet been implemented.
--
-- The solution may also includes a fact 'zdfFpOuputFact', which is
-- not associated with any label:
-- * for a backward problem, this is the fact at entry
-- * for a forward problem, this is the fact at the distinguished exit node,
-- if such a node is present
--
-- For a forward problem only, the solution includes 'zdfFpLastOuts',
-- which is the set of facts on edges leaving the graph.
--
-- The flag 'zdfGraphChanged' tells whether the engine did any rewriting.
class FixedPoint fp where
zdfFpContents :: fp m l e x fact a -> a
zdfFpFacts :: fp m l e x fact a -> BlockEnv fact
zdfFpOutputFact :: fp m l e x fact a -> fact -- entry for backward; exit for forward
zdfDecoratedGraph :: fp m l e x fact a -> ZipGF (fact, m) (fact, l) e x
zdfGraphChanged :: fp m l e x fact a -> ChangeFlag
zdfFpMap :: (a -> b) -> (fp m l e x fact a -> fp m l e x fact b)
-- | The class 'FixedPoint' has two instances: one for forward problems and
-- one for backward problems. The 'CommonFixedPoint' defines all fields
-- common to both. (The instance declarations are uninteresting and appear below.)
data CommonFixedPoint m l e x fact a = FP
{ fp_facts :: BlockEnv fact
, fp_out :: fact -- entry for backward; exit for forward
, fp_changed :: ChangeFlag
, fp_dec_graph :: ZipGF (fact, m) (fact, l) e x
, fp_contents :: a
}
-- | The common fixed point is sufficient for a backward problem.
type BackwardFixedPoint = CommonFixedPoint
-- | A forward problem needs the common fields, plus the facts on the outedges.
data ForwardFixedPoint m l e x fact a = FFP
{ ffp_common :: CommonFixedPoint m l e x fact a
, zdfFpLastOuts :: LastOutFacts fact
}
instance FixedPoint CommonFixedPoint where
zdfFpFacts = fp_facts
zdfFpOutputFact = fp_out
zdfGraphChanged = fp_changed
zdfDecoratedGraph = fp_dec_graph
zdfFpContents = fp_contents
zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a)
instance FixedPoint ForwardFixedPoint where
zdfFpFacts = fp_facts . ffp_common
zdfFpOutputFact = fp_out . ffp_common
zdfGraphChanged = fp_changed . ffp_common
zdfDecoratedGraph = fp_dec_graph . ffp_common
zdfFpContents = fp_contents . ffp_common
zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los
-- | Extraction of the common fixed point, given a function to get the
-- fact emerging from the graph
cfp :: (b -> a) -> c -> DFM a b -> DFM a (CommonFixedPoint m l e x a c)
cfp get_fact c solution =
do { b <- solution
; let emerging = get_fact b
; facts <- getAllFacts
; return $ FP facts emerging NoChange (panic "decoration?!") c }
-- | Extract a fixed point from a backward analysis
bfp :: b -> DFM a a -> DFM a (BackwardFixedPoint m l e x a b)
bfp = cfp id
-- | Extract a fixed point from a forward analysis
ffp :: b -> DFM a (Maybe a) -> DFM a (ForwardFixedPoint m l e x a b)
ffp b exit = do { common <- cfp get_fact b exit
; last_outs <- getLastOutFacts
; return $ FFP common last_outs
}
where get_fact ma = fromMaybe (panic "exit of non-exitable graph") ma
{- ============== SOLVING AND REWRITING ============== -}
type PassName = String
-- | '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.
--
--
-- An iterative solver normally starts with the bottom fact at every
-- node, but it can be useful in other contexts as well. For this
-- reason the initial set of facts (at labelled blocks only) is a
-- parameter to the solver.
--
-- The constraints on the type signature exist purely for debugging;
-- they make it possible to prettyprint nodes and facts. The parameter of
-- type 'PassName' is also used just for debugging.
--
-- Note that the result is a fixed point with no contents, that is,
-- the contents have type ().
--
-- 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 .
class DataflowSolverDirection transfers fixedpt where
zdfSolveFrom :: (DebugNodes m l e x, LastNode 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)
-> ZipGF m l e x -- ^ Graph to be analyzed
-> fixedpt m l e x a () -- ^ Answers
-- There are exactly two instances: forward and backward
instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint
where zdfSolveFrom = solve_f
instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint
where zdfSolveFrom = solve_b
solve_b, rewrite_b_agraph, forward_rew :: a
solve_b = undefined
rewrite_b_agraph = undefined
forward_rew = undefined
-- | zdfRewriteFrom is an overloaded name that resolves to an
-- interleaved analysis and transformation. It too is instantiated in
-- forward and backward directions.
--
-- The type parameters of the class include not only transfer
-- functions and the fixed point but also rewrites and the type
-- constructor (here called 'graph') for making rewritten graphs. As
-- above, in the definitoins of the rewrites, it might simplify
-- matters if 'graph' were replaced with 'ZipGF'.
--
-- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom'
-- with additional parameters and a different result. Of course the
-- rewrites are an additional parameter.
-- The resulting fixed point containts a rewritten graph.
class DataflowSolverDirection transfers fixedpt =>
DataflowDirection transfers fixedpt rewrites where
zdfRewriteFrom :: (DebugNodes m l e x, Outputable a, LastNode l)
=> RewritingDepth -- whether to rewrite a rewritten graph
-> BlockEnv a -- initial facts (unbound == botton)
-> PassName
-> DataflowLattice a
-> transfers m l a
-> rewrites m l a
-> a -- fact flowing in (at entry or exit)
-> ZipGF m l e x
-> FuelMonad (fixedpt m l e x a (ZipGF m l e x))
data RewritingDepth = RewriteShallow | RewriteDeep
-- When a transformation proposes to rewrite a node,
-- you can either ask the system to
-- * "shallow": accept the new graph, analyse it without further rewriting
-- * "deep": recursively analyse-and-rewrite the new graph
-- There are currently four instances, but there could be more
-- forward, backward (instantiates transfers, fixedpt, rewrites)
-- ZipGF, ZipGF (instantiates graph)
instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites
where zdfRewriteFrom = rewrite_f_agraph
instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites
where zdfRewriteFrom = rewrite_b_agraph
{- =================== IMPLEMENTATIONS ===================== -}
-----------------------------------------------------------
-- solve_f: forward, pure
solve_f :: (DebugNodes m l e x, LastNode l, Outputable a)
=> BlockEnv a -- initial facts (unbound == bottom)
-> PassName
-> DataflowLattice a -- lattice
-> ForwardTransfers m l a -- dataflow transfer functions
-> a
-> ZipGF m l e x -- graph to be analyzed
-> ForwardFixedPoint m l e x a () -- answers
solve_f env name lattice transfers in_fact g =
runWithoutFuel $ runDFM lattice $ ffp () $ liftM undefined $
fwd_pure_anal name env transfers (maybe_entry g in_fact) g
maybe_entry :: ZipGF m l e x -> a -> ZMaybe e a
maybe_entry (GF (ZE_C _) _ _) _ = ZNothing
maybe_entry (GF (ZE_O _) _ _) a = ZJust a
maybe_entry (GM _) a = ZJust a
rewrite_f_agraph :: (DebugNodes m l e x, LastNode l, Outputable a)
=> RewritingDepth
-> BlockEnv a
-> PassName
-> DataflowLattice a
-> ForwardTransfers m l a
-> ForwardRewrites m l a
-> a -- fact flowing in (at entry or exit)
-> ZipGF m l e x
-> FuelMonad (ForwardFixedPoint m l e x a (ZipGF m l e x))
rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g =
runDFM lattice $
do fuel <- fuelRemaining
fp <- rewr_fp $ forward_rew maybeRewriteAndUseFuel depth start_facts name
transfers rewrites in_fact g
fuel' <- fuelRemaining
fuelDecrement name fuel fuel'
return fp
where rewr_fp ga = do { (g, a) <- ga ; ffp g $ return a }
maybeRewriteAndUseFuel :: Maybe b -> DFM a (Maybe b)
maybeRewriteAndUseFuel Nothing = return Nothing
maybeRewriteAndUseFuel (Just b) =
do { done <- fuelExhausted
; if done then return Nothing
else fuelDec1 >> (return $ Just b) }
-- convert graph from form produced by rewrite function to form used internally
importGraph :: ZipGF' m l e x -> DFM a (ZipGF m l e x)
importGraph g = liftToDFM $ liftUniq $ g
class (Outputable m, Outputable l, HavingSuccessors l, Outputable (ZipGF m l e x)) => DebugNodes m l e x
fwd_pure_anal :: (DebugNodes m l e x, LastNode l, Outputable a)
=> PassName
-> BlockEnv a
-> ForwardTransfers m l a
-> ZMaybe e a
-> ZipGF m l e x
-> DFM a (ZMaybe x a)
fwd_pure_anal name env transfers in_fact g =
anal_f name env transfers panic_rewrites in_fact g
where -- definitely a case of "I love lazy evaluation"
anal_f = forward_sol (\_ -> return Nothing) panic_depth
panic_rewrites = panic "pure analysis asked for a rewrite function"
panic_depth = panic "pure analysis asked for a rewrite depth"
-----------------------------------------------------------------------
--
-- Here beginneth the super-general functions
--
-- Think of them as (typechecked) macros
-- * They are not exported
--
-- * They are called by the specialised wrappers
-- above, and always inlined into their callers
--
-- There are four functions, one for each combination of:
-- Forward, Backward
-- Solver, Rewriter
--
-- A "solver" produces a (DFM f (f, Fuel)),
-- where f is the fact at entry(Bwd)/exit(Fwd)
-- and from the DFM you can extract
-- the BlockId->f
-- the change-flag
-- and more besides
--
-- A "rewriter" produces a rewritten *Graph* as well
--
-- Both constrain their rewrites by
-- a) Fuel
-- b) RewritingDepth: shallow/deep
-----------------------------------------------------------------------
data ZMaybe x a where
ZJust :: a -> ZMaybe O a
ZNothing :: ZMaybe C a
unZMaybe :: ZMaybe x a -> Maybe a
unZMaybe (ZJust a) = Just a
unZMaybe (ZNothing) = Nothing
fromZJust :: ZMaybe O a -> a
fromZJust (ZJust a) = a
-- continuation types
type FactKont a b = a -> DFM a b
type LOFsKont a b = LastOutFacts a -> DFM a b
type Kont a b = DFM a b
type ZKont ex a b = ZMaybe ex a -> DFM a b
-- solves a single-entry, at-most-one-exit, graph fragment given
-- an input fact a and input Fuel, producing a possible output fact
-- and remaining Fuel
forward_sol
:: forall m l e x a .
(DebugNodes m l e x, LastNode l, Outputable a)
=> (forall b . Maybe b -> DFM a (Maybe b))
-- Squashes proposed rewrites if there is
-- no more fuel; OR if we are doing a pure
-- analysis, so totally ignore the rewrite
-- ie. For pure-analysis the fn is (\f _ -> (f, Nothing)).
-- Also accounts for fuel consumption.
-> RewritingDepth -- Shallow/deep
-> PassName
-> BlockEnv a -- Initial set of facts
-> ForwardTransfers m l a
-> ForwardRewrites m l a
-> ZMaybe e a -- Entry fact
-> ZipGF m l e x
-> DFM a (ZMaybe x a)
forward_sol with_fuel = forw -- see [Note inlining] below
where
forw :: RewritingDepth
-> PassName
-> BlockEnv a
-> ForwardTransfers m l a
-> ForwardRewrites m l a
-> ZMaybe e a
-> ZipGF m l e x
-> DFM a (ZMaybe x a)
forw depth name start_facts transfers rewrites =
\in_fact g -> do { setAllFacts start_facts ; solve_ex g in_fact }
where
-- the solver is executed mostly for side effect;
-- it may take an OO or OC graph.
solve_ex :: ZipGF m l e x -> ZKont e a (ZMaybe x a)
solve_ex (GM mids) (ZJust a) = solve_mids mids (return . ZJust) a
solve_ex (GM _) (ZNothing) = can't_match
solve_ex g@(GF entry blocks exit) in' =
do { set_locals blocks exit
; solve_entry entry set_last in'
; solve_blocks (postorder_dfs g)
; solve_exit exit }
where set_locals :: BlockEnv (Block m l) -> ZExit m x -> DFM a ()
set_locals blocks (ZX_O exit) = set_local_blocks_with_exit blocks exit
set_locals blocks ZX_C = set_local_blocks blocks
solve_entry :: ZEntry m l e -> LOFsKont a b -> ZKont e a b
solve_exit :: ZExit m x -> Kont a (ZMaybe x a)
solve_entry (ZE_O tail) k (ZJust a) = solve_tail tail k a
solve_entry (ZE_C _) k (ZNothing) = k $ LastOutFacts []
solve_entry _ _ _ = can't_match
solve_exit (ZX_O head) = solve_head head (return . ZJust)
solve_exit (ZX_C) = return ZNothing
-- From here out, we present myriad solver functions, starting with
-- individual nodes and working our way up to graphs
-- not clear where to put this tidbit---it's the side-effecting action that
-- updates the internal state of the dataflow monad. Everything else boils
-- down to calling @set_last@ to do the deed... XXX
set_last :: LOFsKont a ()
set_last (LastOutFacts l) = mapM_ (uncurry setFact) l
-- In order to compose continuations, the order of arguments no longer
-- reflects the flow of a fact through a node. Instead we want to
-- be able to partially apply a solver to a thing and take the
-- input fact and fuel as later arguments.
-- XXX we would like to see if solve_first, solve_mid, and solve_last
-- can each be obtained as a partial application of a single higher-order
-- function. We just want to know if it can be done, even if we believe
-- the higher-order version may be harder to understand and therefore
-- not worthy to be deployed.
----------- SOLVER FUNCTIONS FOR NODES --------------
-- the types are all CPS-style types, but with three different
-- types of continuations which very by enterability and exitability
solve_first :: BlockId -> FactKont a b -> Kont a b
solve_first id k =
do { idfact <- getFact id
; (with_fuel $ fr_first rewrites id idfact) >>= \x -> case x of
Nothing -> k (ft_first_out transfers id idfact)
Just g ->
do { g <- importGraph g
; a <- subAnalysis' $
case depth of
RewriteDeep -> solve_CO' id g return
RewriteShallow -> anal_f_CO g
; k a } }
solve_mid :: m -> FactKont a b -> FactKont a b
solve_mid m k in' =
(with_fuel $ fr_middle rewrites m in') >>= \x -> case x of
Nothing -> k (ft_middle_out transfers m in')
Just g ->
do { g <- importGraph g
; a <- subAnalysis' $
case depth of
RewriteDeep -> solve_OO' g return in'
RewriteShallow -> anal_f_OO g in'
; k a }
solve_last :: l -> LOFsKont a b -> FactKont a b
solve_last l k in' =
(with_fuel $ fr_last rewrites l in') >>= \x -> case x of
Nothing -> k (ft_last_outs transfers l in')
Just g ->
do { g <- importGraph g
; (last_outs :: LastOutFacts a) <- subAnalysis' $
case depth of
RewriteDeep -> solve_OC' g return in'
RewriteShallow -> anal_f_OC g in'
; k last_outs }
----------- SOLVER FUNCTIONS FOR SEQUENCES OF NODES -----------
solve_mids :: ZMids m -> FactKont a b -> FactKont a b
solve_mids (ZUnit) = id
solve_mids (ZMid m) = solve_mid m
solve_mids (ZCat m1 m2) = solve_mids m1 . solve_mids m2
solve_tail :: ZTail m l -> LOFsKont a b -> FactKont a b
solve_tail (ZTail m t) = solve_mid m . solve_tail t
solve_tail (ZLast l) = solve_last l
solve_head :: ZHead m -> FactKont a b -> Kont a b
solve_head (ZHead h m) = solve_head h . solve_mid m
solve_head (ZFirst id) = solve_first id
solve_block :: Block m l -> Kont a ()
solve_block (Block id tail) = solve_first id $ solve_tail tail $ set_last
----------- SOLVER FUNCTIONS FOR GRAPHS --------------
solve_blocks :: [Block m l] -> Kont a ()
solve_blocks = run "forward" name solve_block
--- the reason this falls out so nicely is that solve_block
--- is executed only for side effect (just like the old
--- 'set_successor_facts'
-- primed functions perform dynamic checks; we may one day
-- want to refine types to eliminate the dynamic checks
solve_CO' :: BlockId -> ZipGF m l C O -> FactKont a b -> Kont a b
solve_OO' :: ZipGF m l O O -> FactKont a b -> FactKont a b
solve_OC' :: ZipGF m l O C -> LOFsKont a b -> FactKont a b
solve_CO' id (GF (ZE_C id2) blocks (ZX_O exit)) =
ASSERT( id == id2 ) solve_CO id2 blocks exit
solve_CO' _ _ = can't_match
solve_OO' (GM mids) = solve_mids mids
solve_OO' (GF (ZE_O entry) blocks (ZX_O exit)) = solve_OO entry blocks exit
solve_OO' _ = can't_match
solve_OC' (GF (ZE_O entry) blocks ZX_C) = solve_OC entry blocks
solve_OC' _ = can't_match
-- from here down, the dynamic checks have already been done
solve_CO :: BlockId -> BlockEnv (Block m l) -> ZHead m
-> FactKont a b -> Kont a b
solve_OO :: ZTail m l -> BlockEnv (Block m l) -> ZHead m
-> FactKont a b -> FactKont a b
solve_OC :: ZTail m l -> BlockEnv (Block m l)
-> LOFsKont a b -> FactKont a b
solve_OO entry blocks exit k in' =
do { set_local_blocks_with_exit blocks exit
; solve_tail entry set_last in'
; solve_blocks (postorder_dfs_from blocks entry)
; solve_head exit k }
solve_CO id blocks exit k =
do { set_local_blocks_with_exit blocks exit
; solve_blocks (postorder_dfs_from blocks (BlockPtr id))
; solve_head exit k }
solve_OC entry blocks k in' =
do { set_local_blocks blocks
; solve_tail entry set_last in'
; solve_blocks (postorder_dfs_from blocks entry)
; facts <- getLastOutFacts
; k facts }
----------- ANALYSIS FUNCTIONS FOR SHALLOW REWRITING --------
-- inputs of each analysis depend on whether entry is open;
-- outputs depend on whether exit is open:
anal_f_OO :: ZipGF m l O O -> a -> DFM a a
anal_f_OC :: ZipGF m l O C -> a -> DFM a (LastOutFacts a)
anal_f_CO :: ZipGF m l C O -> DFM a a
-- we have only one top-level analysis, so we specialize anal_f
anal_f_OO g = anal_f g (return . fromZJust) . ZJust
anal_f_OC g = anal_f g (\ _ -> getLastOutFacts) . ZJust
anal_f_CO g = anal_f g (return . fromZJust) ZNothing
anal_f :: ZipGF m l e x -> (ZKont x a b) -> ZKont e a b
anal_f g finish in' = getAllFacts >>= \env ->
fwd_pure_anal name env transfers in' g >>= finish
-- XXX is this correct or do we want the empty env?
newtype BlockPtr = BlockPtr BlockId -- pointer to a successor block
instance HavingSuccessors BlockPtr where
fold_succs add (BlockPtr id) z = add id z
set_local_blocks :: (DataflowAnalysis df) => BlockEnv b -> df a ()
set_local_blocks_with_exit :: (DataflowAnalysis df) => BlockEnv b -> ZHead m -> df a ()
set_local_blocks blockenv = setInternalBlocks $ is_internal blockenv
set_local_blocks_with_exit blockenv exit =
setInternalBlocks $ is_internal blockenv `orp` (== label exit)
where label (ZFirst id) = id
label (ZHead h _) = label h
orp p q x = p x || q x
is_internal :: BlockEnv a -> BlockId -> Bool
is_internal env = isJust . lookupBlockEnv env
getLastOutFacts :: DFM f (LastOutFacts f)
getLastOutFacts = bareLastOutFacts >>= return . LastOutFacts
type GraphFactKont m l e x a b = ZipGF m l e x -> a -> DFM a b
type GraphKont m l e x a b = ZipGF m l e x -> DFM a b
{-
forward_rew
:: forall m l e x a .
(DebugNodes m l e x, LastNode l, Outputable a)
=> (forall b . Maybe b -> DFM a (Maybe b))
-> RewritingDepth
-> BlockEnv a
-> PassName
-> ForwardTransfers m l a
-> ForwardRewrites m l a
-> a
-> ZipGF m l
-> DFM a (ZipGF m l, Maybe a)
forward_rew with_fuel = forw
where
forw :: RewritingDepth
-> BlockEnv a
-> PassName
-> ForwardTransfers m l a
-> ForwardRewrites m l a
-> a
-> ZipGF m l
-> DFM a (ZipGF m l, Maybe a)
forw depth start_facts name transfers rewrites in_fact g =
do setAllFacts start_facts
sar_Ox g (\ma g -> return (g, ma)) in_fact
where
----------- REWRITE FUNCTIONS FOR NODES --------------
rew_first :: BlockId -> GraphFactKont m l e x a b -> GraphKont m l e x a b
rew_first id k head =
do a <- getFact id
(with_fuel $ fr_first rewrites id a) >>= \x -> case x of
Nothing -> k (head `appId` id) (ft_first_out transfers id a)
Just g ->
do { markGraphRewritten
; g <- importGraph g
; (g, a) <- subAnalysis' $
case depth of
RewriteDeep -> sar_CO id g return2
RewriteShallow -> do { a <- anal_f_CO id g; return (g, a) }
; k (head <*> g) a }
rew_mid :: m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
rew_mid m k head in' =
my_trace "Rewriting middle node" (ppr m) $
(with_fuel $ fr_middle rewrites m in') >>= \x -> case x of
Nothing -> k (head `appMid` m) (ft_middle_out transfers m in')
Just g ->
do { markGraphRewritten
; g <- importGraph g
; (g, a) <- subAnalysis' $
case depth of
RewriteDeep -> sar_OO g return2 in'
RewriteShallow -> do { a <- anal_f_OO g in'; return (g, a) }
; k (head <*> g) a }
rew_last :: l -> GraphKont m l e x a b -> GraphFactKont m l e x a b
rew_last l k head in' =
my_trace "Rewriting last node" (ppr l) $
(with_fuel $ fr_last rewrites l in') >>= \x -> case x of
Nothing -> do check_facts in' l -- redundant error checking
k (head <=*> (ZLast l::ZTail m l))
Just g ->
do { markGraphRewritten
; g <- importGraph g
; g <- subAnalysis' $
case depth of
RewriteDeep -> sar_OC g return in'
RewriteShallow -> return g
; k (head <*> g) }
where check_facts in' l =
let LastOutFacts last_outs = ft_last_outs transfers l in'
in mapM (uncurry checkFactMatch) last_outs
----------- REWRITE FUNCTIONS FOR SEQUENCES OF NODES --------------
rew_mids :: ZMids m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
rew_mids (ZUnit) = id
rew_mids (ZMid m) = rew_mid m
rew_mids (ZCat m1 m2) = rew_mids m1 . rew_mids m2
rew_tail :: ZTail m l -> GraphKont m l e x a b -> GraphFactKont m l e x a b
rew_tail (ZTail m t) = rew_mid m . rew_tail t
rew_tail (ZLast l) = rew_last l
rew_head :: ZHead m -> GraphFactKont m l e x a b -> GraphKont m l e x a b
rew_head (ZHead h m) = rew_head h . rew_mid m
rew_head (ZFirst id) = rew_first id
rew_block :: Block m l -> GraphKont m l e x a b -> GraphKont m l e x a b
rew_block (Block id tail) = rew_first id . rew_tail tail
rew_blocks :: [Block m l] -> GraphKont m l e x a b -> GraphKont m l e x a b
rew_blocks = flip (foldr rew_block)
-- 'foldl (flip rew_block)' might consume less stack than 'foldr rew_block'?
-------- ANALYSIS FUNCTIONS FOR NON-REWRITTEN GRAPHS -----
-- this code is almost exact duplicate of solver code
anal_f :: (Maybe a -> DFM a b) -> ZipGF m l e x -> a -> DFM a b
anal_f finish g in' = subAnalysis $
do { env <- getAllFacts ; fwd_pure_anal name env transfers in' g >>= finish }
anal_f_OO :: ZipGF m l e x -> a -> DFM a a
anal_f_OO = anal_f (return . fromMaybe (panic "no exit fact?!"))
anal_f_CO :: BlockId -> ZipGF m l e x -> DFM a a
anal_f_CO id g = botFact >>= anal_f_OO (mkLast (mkBranchNode id) <*> g)
-- exact duplicate ends
solve :: GraphFactKont m l e x a (Maybe a)
solve g in' =
do { facts <- getAllFacts
; forward_sol with_fuel depth name facts transfers rewrites in' g }
-------- SOLVE-AND-REWRITE COMBINATIONS FOR GRAPHS ----------
-- sar_ex == solve-and-rewrite entry exit
sar_Ox :: ZipGF m l e x -> (Maybe a -> GraphKont m l e x a b) -> FactKont a b
sar_Ox g@(GF _ _ Nothing) pre_k = sar_OC g (pre_k Nothing)
sar_Ox g pre_k = sar_OO g (\g a -> pre_k (Just a) g)
sar_OO :: ZipGF m l e x -> GraphFactKont m l e x a b -> FactKont a b
sar_CO :: BlockId -> ZipGF m l e x -> GraphFactKont m l e x a b -> Kont a b
sar_OC :: ZipGF m l e x -> GraphKont m l e x a b -> FactKont a b
sar_OO g k in' = solve g in' >> rew_OO' g k emptyZipGF in'
sar_OC g k in' = solve g in' >> rew_OC' g k emptyZipGF in'
sar_CO id g k =
do { in' <- botFact; solve g' in' ; rew_CO' id g k emptyZipGF }
where g' = mkLast (mkBranchNode id) <*> g
----------------- REWRITE FUNCTIONS FOR GRAPHS ---------------
rew_OO' :: ZipGF m l e x -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
rew_OC' :: ZipGF m l e x -> GraphKont m l e x a b -> GraphFactKont m l e x a b
rew_CO' :: BlockId -> ZipGF m l e x -> GraphFactKont m l e x a b -> GraphKont m l e x a b
rew_OO' (GM mids) = rew_mids mids
rew_OO' (GF (Just entry) blockenv (Just exit)) = rew_OO entry blockenv exit
rew_OO' _ = panic "EX graph missing entry or exit"
rew_OC' (GF (Just entry) blockenv Nothing) = rew_OC entry blockenv
rew_OC' _ = panic "EJ graph is exitable"
rew_CO' id (GF Nothing blockenv (Just exit)) = rew_CO id blockenv exit
rew_CO' _ _ = panic "BX graph is enterable"
rew_OO :: ZTail m l e x -> BlockEnv (Block m l) -> ZHead m
-> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
rew_OC :: ZTail m l e x -> BlockEnv (Block m l)
-> GraphKont m l e x a b -> GraphFactKont m l e x a b
rew_CO :: BlockId -> BlockEnv (Block m l) -> ZHead m
-> GraphFactKont m l e x a b -> GraphKont m l e x a b
rew_OO entry blockenv exit =
rew_tail entry .
rew_blocks (postorder_dfs_from blockenv entry) .
rew_head exit
rew_OC entry blockenv =
rew_tail entry .
rew_blocks (postorder_dfs_from blockenv entry)
rew_CO id blockenv exit =
rew_blocks (postorder_dfs_from blockenv (BlockPtr id)) .
rew_head exit
-}
return2 :: Monad m => a -> b -> m (a, b)
return2 = curry return
{-
{- ================== ONCE MORE, ONLY BACKWARD THIS TIME =========================== -}
solve_b :: (DebugNodes m l e x, Outputable a)
=> BlockEnv a -- initial facts (unbound == bottom)
-> PassName
-> DataflowLattice a -- lattice
-> BackwardTransfers m l a -- dataflow transfer functions
-> a -- exit fact
-> ZipGF m l e x -- graph to be analyzed
-> BackwardFixedPoint m l e x a () -- answers
solve_b env name lattice transfers exit_fact g =
runWithoutFuel $ runDFM lattice $ bfp () $
bwd_pure_anal name env transfers g exit_fact
rewrite_b_agraph :: (DebugNodes m l e x, Outputable a)
=> RewritingDepth
-> BlockEnv a
-> PassName
-> DataflowLattice a
-> BackwardTransfers m l a
-> BackwardRewrites m l a
-> a -- fact flowing in at exit
-> ZipGF m l
-> FuelMonad (BackwardFixedPoint m l e x a (ZipGF m l))
rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
runDFM lattice $
do fuel <- fuelRemaining
fp <- rewr_fp $ backward_rew maybeRewriteAndUseFuel depth start_facts name
transfers rewrites g exit_fact
fuel' <- fuelRemaining
fuelDecrement name fuel fuel'
return fp
where rewr_fp ga = do { (g, a) <- ga ; bfp g $ return a }
bwd_pure_anal :: (DebugNodes m l e x, HavingSuccessors l, Outputable a)
=> PassName
-> BlockEnv a
-> BackwardTransfers m l a
-> ZipGF m l
-> a
-> DFM a a
bwd_pure_anal name env transfers g exit_fact =
anal_b name env transfers panic_rewrites g exit_fact
where -- another case of "I love lazy evaluation"
anal_b = backward_sol (\ _ -> return Nothing) panic_depth
panic_rewrites = panic "pure analysis asked for a rewrite function"
panic_depth = panic "pure analysis asked for a rewrite depth"
backward_sol :: forall m l e x a .
(DebugNodes m l e x, HavingSuccessors l, Outputable a)
=> (forall b . Maybe b -> DFM a (Maybe b))
-> RewritingDepth
-> PassName
-> BlockEnv a
-> BackwardTransfers m l a
-> BackwardRewrites m l a
-> ZipGF m l
-> a
-> DFM a a
backward_sol with_fuel = back -- see [Note inlining] below
where
back :: RewritingDepth
-> PassName
-> BlockEnv a
-> BackwardTransfers m l a
-> BackwardRewrites m l a
-> ZipGF m l
-> a
-> DFM a a
back depth name start_facts transfers rewrites =
\ g exit_fact -> do { setAllFacts start_facts; solve_Ox g exit_fact }
where
solve_Ox :: ZipGF m l e x -> FactKont a a
solve_Ox g@(GF Nothing _ _) = \_ -> solve_OC' g return
solve_Ox g = solve_OO' g return
----------- SOLVER FUNCTIONS FOR NODES --------------
solve_first :: BlockId -> Kont a b -> FactKont a b
solve_first id k a =
(with_fuel $ br_first rewrites id a) >>= \x -> case x of
Nothing -> do { my_trace "solve_first" (ppr id <+> text "=" <+>
ppr (bt_first_in transfers id a)) $
setFact id $ bt_first_in transfers id a
; k }
Just g ->
do { g <- importGraph g
; my_trace "analysis rewrites first node" (ppr id <+> ppr g) $
subAnalysis' $
case depth of
RewriteDeep -> solve_CO' id g (return ()) a
RewriteShallow -> anal_b_CO g a
; k }
solve_mid :: m -> FactKont a b -> FactKont a b
solve_mid m k a =
(with_fuel $ br_middle rewrites m a) >>= \x -> case x of
Nothing -> k (bt_middle_in transfers m a)
Just g ->
do { g <- importGraph g
; a <-
my_trace "analysis rewrites middle node" (ppr m <+> ppr g) $
subAnalysis' $
case depth of
RewriteDeep -> solve_OO' g return a
RewriteShallow -> anal_b_OO g a
; k a }
solve_last :: l -> FactKont a b -> Kont a b
solve_last l k =
do env <- factsEnv
(with_fuel $ br_last rewrites l env) >>= \x -> case x of
Nothing -> k (bt_last_in transfers l env)
Just g ->
do { g <- importGraph g
; a <-
my_trace "analysis rewrites last node" (ppr l <+> ppr g) $
subAnalysis' $
case depth of
RewriteDeep -> solve_OC' g return
RewriteShallow -> anal_b_OC g
; k a }
----------- SOLVER FUNCTIONS FOR SEQUENCES OF NODES -----------
-- bodies and type signatures are dual to forward case
-- (swap FactKont and Kont)
solve_mids :: ZMids m -> FactKont a b -> FactKont a b
solve_mids (ZUnit) = id
solve_mids (ZMid m) = solve_mid m
solve_mids (ZCat m1 m2) = solve_mids m2 . solve_mids m1
solve_tail :: ZTail m l -> FactKont a b -> Kont a b
solve_tail (ZTail m t) = solve_tail t . solve_mid m
solve_tail (ZLast l) = solve_last l
solve_head :: ZHead m -> Kont a b -> FactKont a b
solve_head (ZHead h m) = solve_mid m . solve_head h
solve_head (ZFirst id) = solve_first id
solve_block :: Block m l -> Kont a ()
solve_block (Block id tail) = solve_tail tail $ solve_first id $ return ()
----------- SOLVER FUNCTIONS FOR GRAPHS --------------
solve_blocks :: [Block m l] -> Kont a ()
solve_blocks = run "backward" name solve_block
-- primed functions perform dynamic checks; we may one day
-- want to refine types to eliminate the dynamic checks
solve_CO' :: BlockId -> ZipGF m l e x -> Kont a b -> FactKont a b
solve_OO' :: ZipGF m l e x -> FactKont a b -> FactKont a b
solve_OC' :: ZipGF m l e x -> FactKont a b -> Kont a b
solve_CO' id (GF Nothing blocks (Just exit)) = solve_CO id blocks exit
solve_CO' _ _ = panic "solve_CO given enterable or unexitable graph"
solve_OO' (GM mids) = solve_mids mids
solve_OO' (GF (Just entry) blocks (Just exit)) = solve_OO entry blocks exit
solve_OO' _ = panic "solve_OO given unenterable or unexitable graph"
solve_OC' (GF (Just entry) blocks Nothing) = solve_OC entry blocks
solve_OC' _ = panic "solve_OC given unenterable or exitable graph"
-- from here down, the dynamic checks have already been done
solve_CO :: BlockId -> BlockEnv (Block m l) -> ZHead m
-> Kont a b -> FactKont a b
solve_OO :: ZTail m l -> BlockEnv (Block m l) -> ZHead m
-> FactKont a b -> FactKont a b
solve_OC :: ZTail m l -> BlockEnv (Block m l)
-> FactKont a b -> Kont a b
solve_OO entry blocks exit k a =
do { set_local_blocks_with_exit blocks exit
; solve_head exit (return ()) a
; solve_blocks (reverse $ postorder_dfs_from blocks entry)
; solve_tail entry k }
solve_CO id blocks exit k a =
do { set_local_blocks_with_exit blocks exit
; solve_head exit (return ()) a
; solve_blocks (reverse $ postorder_dfs_from blocks (BlockPtr id))
; k }
solve_OC entry blocks k =
do { set_local_blocks blocks
; solve_blocks (reverse $ postorder_dfs_from blocks entry)
; solve_tail entry k }
----------- ANALYSIS FUNCTIONS FOR SHALLOW REWRITING --------
-- inputs of each analysis depend on whether exit is open;
-- outputs depend on whether entry is open:
anal_b_OO :: ZipGF m l e x -> a -> DFM a a
anal_b_OC :: ZipGF m l e x -> DFM a a
anal_b_CO :: ZipGF m l e x -> a -> DFM a ()
-- we have only one top-level analysis, so we specialize anal_b
anal_b_OO = anal_b return
anal_b_OC g = do a <- return $ panic "closed graph used exit fact"
anal_b return g a
anal_b_CO = anal_b (const $ return ())
anal_b :: (a -> DFM a b) -> ZipGF m l e x -> a -> DFM a b
anal_b finish g a = getAllFacts >>= \env ->
bwd_pure_anal name env transfers g a >>= finish
-- XXX is this correct or do we want the empty env?
{- ================================================================ -}
backward_rew
:: forall m l e x a .
(DebugNodes m l e x, HavingSuccessors l, Outputable a)
=> (forall b . Maybe b -> DFM a (Maybe b))
-> RewritingDepth
-> BlockEnv a
-> PassName
-> BackwardTransfers m l a
-> BackwardRewrites m l a
-> ZipGF m l
-> a
-> DFM a (ZipGF m l, a)
backward_rew with_fuel = back -- see [Note inline]
where
back :: RewritingDepth
-> BlockEnv a
-> PassName
-> BackwardTransfers m l a
-> BackwardRewrites m l a
-> ZipGF m l
-> a
-> DFM a (ZipGF m l, a)
back depth start_facts name transfers rewrites gx exit_fact =
do { setAllFacts start_facts; sar_Ox gx return2 exit_fact }
where
----------- REWRITE FUNCTIONS FOR NODES --------------
rew_first :: BlockId -> GraphKont m l e x a b -> GraphFactKont m l e x a b
rew_first id k tail a =
(with_fuel $ br_first rewrites id a) >>= \x -> case x of
Nothing -> check_k (mkLabel id <*> tail) (bt_first_in transfers id a)
Just g ->
do { markGraphRewritten
; g <- importGraph g
; my_trace "Rewrote first node"
(f4sep [ppr id <> colon, text "to", ppr g]) $ return ()
; g <-
case depth of
RewriteDeep -> sar_CO id g return a
RewriteShallow -> do { anal_b_CO g a; return g }
; k (g <*> tail) }
where check_k tail a =
do { if check then checkFactMatch id a else return ()
; k tail }
rew_mid :: m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
rew_mid m k tail a =
(with_fuel $ br_middle rewrites m a) >>= \x -> case x of
Nothing -> k (m `preMid` tail) (bt_middle_in transfers m a)
Just g ->
do { markGraphRewritten
; g <- importGraph g
; my_trace "With Facts" (ppr a) $ return ()
; my_trace " Rewrote middle node"
(f4sep [ppr m, text "to", ppr g]) $
return ()
; (g, a) <-
case depth of
RewriteDeep -> sar_OO g return2 a
RewriteShallow -> do { a <- anal_b_OO g a; return (g, a) }
; k (g <*> tail) a }
rew_last :: l -> GraphFactKont m l e x a b -> GraphKont m l e x a b
rew_last l k tail =
do { env <- factsEnv
; (with_fuel $ br_last rewrites l env) >>= \x -> case x of
Nothing ->
k (mkLast l <*> tail) (bt_last_in transfers l env)
Just g ->
do { markGraphRewritten
; g <- importGraph g
; (g, a) <-
case depth of
RewriteDeep -> sar_OC g return2
RewriteShallow -> do { a <- anal_b_OC g; return (g, a) }
; k (g <*> tail) a } }
----------- REWRITE FUNCTIONS FOR SEQUENCES OF NODES --------------
rew_mids :: ZMids m -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
rew_mids (ZUnit) = id
rew_mids (ZMid m) = rew_mid m
rew_mids (ZCat m1 m2) = rew_mids m2 . rew_mids m1
rew_tail :: ZTail m l -> GraphFactKont m l e x a b -> GraphKont m l e x a b
rew_tail (ZTail m t) = rew_tail t . rew_mid m
rew_tail (ZLast l) = rew_last l
rew_head :: ZHead m -> GraphKont m l e x a b -> GraphFactKont m l e x a b
rew_head (ZHead h m) = rew_mid m . rew_head h
rew_head (ZFirst id) = rew_first id
rew_block :: Block m l -> GraphKont m l e x a b -> GraphKont m l e x a b
rew_block (Block id tail) = rew_tail tail . rew_first id
rew_blocks :: [Block m l] -> GraphKont m l e x a b -> GraphKont m l e x a b
rew_blocks = flip (foldr rew_block)
-- 'foldl (flip rew_block)' might consume less stack than 'foldr rew_block'?
-------- ANALYSIS FUNCTIONS FOR NON-REWRITTEN GRAPHS -----
-- this code is almost exact duplicate of solver code
anal_b :: (a -> DFM a b) -> ZipGF m l e x -> a -> DFM a b
anal_b finish g a = subAnalysis $
do { env <- getAllFacts ; bwd_pure_anal name env transfers g a >>= finish }
anal_b_OO :: ZipGF m l e x -> a -> DFM a a
anal_b_OO = anal_b return
anal_b_CO :: ZipGF m l e x -> a -> DFM a ()
anal_b_CO = anal_b (const $ return ())
anal_b_OC :: ZipGF m l e x -> DFM a a
anal_b_OC = \g -> anal_b return g (panic "closed graph used exit fact")
-- exact duplicate ends
solve :: GraphFactKont m l e x a a
solve g a =
do { facts <- getAllFacts
; backward_sol with_fuel depth name facts transfers rewrites g a }
-------- SOLVE-AND-REWRITE COMBINATIONS FOR GRAPHS ----------
-- sar_ex == solve-and-rewrite entry exit
sar_Ox :: ZipGF m l e x -> GraphFactKont m l e x a b -> FactKont a b
sar_Ox g@(GF _ _ Nothing) = \ k _ -> sar_OC g k
sar_Ox g = sar_OO g
sar_OO :: ZipGF m l e x -> GraphFactKont m l e x a b -> FactKont a b
sar_CO :: BlockId -> ZipGF m l e x -> GraphKont m l e x a b -> FactKont a b
sar_OC :: ZipGF m l e x -> GraphFactKont m l e x a b -> Kont a b
sar_OO g k a = solve g a >> rew_OO' g k emptyZipGF a
sar_OC g k = solve g nx >> rew_OC' g k emptyZipGF
sar_CO id g k a = solve g a >> rew_CO' id g k emptyZipGF a
nx = panic "non-exitable graph tried to use exit fact"
----------------- REWRITE FUNCTIONS FOR GRAPHS ---------------
rew_OO' :: ZipGF m l e x -> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
rew_OC' :: ZipGF m l e x -> GraphFactKont m l e x a b -> GraphKont m l e x a b
rew_CO' :: BlockId -> ZipGF m l e x -> GraphKont m l e x a b -> GraphFactKont m l e x a b
rew_OO' (GM mids) = rew_mids mids
rew_OO' (GF (Just entry) blockenv (Just exit)) = rew_OO entry blockenv exit
rew_OO' _ = panic "EX graph missing entry or exit"
rew_OC' (GF (Just entry) blockenv Nothing) = rew_OC entry blockenv
rew_OC' _ = panic "EJ graph is exitable"
rew_CO' id (GF Nothing blockenv (Just exit)) = rew_CO id blockenv exit
rew_CO' _ _ = panic "BX graph is enterable"
rew_OO :: ZTail m l e x -> BlockEnv (Block m l) -> ZHead m
-> GraphFactKont m l e x a b -> GraphFactKont m l e x a b
rew_OC :: ZTail m l -> BlockEnv (Block m l)
-> GraphFactKont m l e x a b -> GraphKont m l e x a b
rew_CO :: BlockId -> BlockEnv (Block m l) -> ZHead m
-> GraphKont m l e x a b -> GraphFactKont m l e x a b
rew_OO entry blockenv exit =
rew_head exit .
rew_blocks (reverse $ postorder_dfs_from blockenv entry) .
rew_tail entry
rew_OC entry blockenv =
rew_blocks (reverse $ postorder_dfs_from blockenv entry) .
rew_tail entry
rew_CO id blockenv exit =
rew_head exit .
rew_blocks (postorder_dfs_from blockenv (BlockPtr id))
-}
check :: Bool -- whether to do extra checking during execution
check = True
{- ================================================================ -}
dump_things :: Bool
dump_things = False
my_trace :: String -> SDoc -> a -> a
my_trace = if dump_things then pprTrace else \_ _ a -> a
-- | Here's a function to run an action on blocks until we reach a fixed point.
-- It changes facts but leaves the fuel supply untouched.
run :: (Outputable a, Outputable m, Outputable l) =>
String -> String -> (Block m l -> DFM a ()) -> [Block m l] -> DFM a ()
run dir name do_block blocks =
do { show_blocks $ iterate (1::Int) }
where
-- N.B. Each iteration starts and finished with the same fuel supply;
-- only rewrites in a rewriting function actually count
trace_block cnt block =
do my_trace "about to do" (text name <+> text "on" <+>
ppr (blockId block) <+> ppr cnt) $
do_block block
return (cnt + 1)
iterate n =
do { markFactsUnchanged
; my_trace "block count:" (ppr (length blocks)) $
withDuplicateFuel $ foldM trace_block (0 :: Int) blocks
; changed <- factsStatus
; facts <- getAllFacts
; let depth = 0 -- was nesting depth
; ppIter depth n $
case changed of
NoChange -> unchanged depth $ return ()
SomeChange ->
pprFacts depth n facts $
if n < 1000 then iterate (n+1)
else panic $ msg n
}
msg n = concat [name, " didn't converge in ", show n, " " , dir, " iterations"]
my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
ppIter depth n =
my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
unchanged depth =
my_nest depth (text "facts for" <+> graphId <+> text "are unchanged")
graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "" }
show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
pprBlock (Block id t) = nest 2 (pprFact (id, t))
pprFacts depth n env =
my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
(nest 2 $ vcat $ map pprFact $ blockEnvToList env))
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
f4sep :: [SDoc] -> SDoc
f4sep [] = fsep []
f4sep (d:ds) = fsep (d : map (nest 4) ds)
subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => m f a -> m f a
subAnalysis' m =
do { a <- subAnalysis $
do { a <- m; -- facts <- getAllFacts
; -- my_trace "after sub-analysis facts are" (pprFacts facts) $
return a }
-- ; facts <- getAllFacts
; -- my_trace "in parent analysis facts are" (pprFacts facts) $
return a }
-- where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
-- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
{-
[Note inlining]
~~~~~~~~~~~~~~~
The definitions of 'forward_sol' and 'backward_sol' are curried in a funny
way because we badly want GHC to inline and specialize the partial application
forward_sol (\_ _ -> Nothing)
NR checked on this property ages ago (summer 2007), but it needs to be checked
again once things will have stabilized in mid-2009.
-}
{- ================= EXTRA UTILITY SPLICING FUNCTIONS ================ -}
appId :: ZipGF m l e C -> BlockId -> ZipGF m l e O -- splice new label onto closed graph
appId (GF entry blocks ZX_C) id = GF entry blocks (ZX_O $ ZFirst id)
appId _ _ = can't_match
-- based on no measurement whatever, NR felt this special case was
-- worth optimizing (avoids allocating 'ZMid m' in the 'GF' case):
-- appMid g m = g <=*> ZMid m
appMid :: ZipGF m l e O -> m -> ZipGF m l e O
appMid (GM ms) m = GM $ ZCat ms (ZMid m)
appMid (GF entry blocks (ZX_O h)) m = GF entry blocks (ZX_O $ ZHead h m)
--appMid (GF _ _ ZX_C) _ = can't_match
preMid :: m -> ZipGF m l O x -> ZipGF m l O x
preMid m (GM ms) = GM $ ZCat (ZMid m) ms
preMid m (GF (ZE_O t) blocks exit) = GF (ZX_O $ ZTail m t) blocks exit
--preMid _ (GF (ZE_C _) _ _) = can't_match
can't_match :: a
can't_match = panic "GADT pattern matcher is too stupid to live"