module Compiler.Hoopl.Dataflow
( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..)
, ChangeFlag(..), changeIf
, FwdPass(..), FwdTransfer, FwdRewrite, SimpleFwdRewrite
, noFwdRewrite, thenFwdRw, shallowFwdRw, deepFwdRw
, BwdPass(..), BwdTransfer, BwdRewrite, SimpleBwdRewrite
, noBwdRewrite, thenBwdRw, shallowBwdRw, deepBwdRw
, Fact
, analyzeAndRewriteFwd, analyzeAndRewriteBwd
)
where
import Compiler.Hoopl.Fuel
import Compiler.Hoopl.Graph
import qualified Compiler.Hoopl.GraphUtil as U
import Compiler.Hoopl.Label
import Compiler.Hoopl.MkGraph (AGraph)
data DataflowLattice a = DataflowLattice
{ fact_name :: String
, fact_bot :: a
, fact_extend :: JoinFun a
, fact_do_logging :: Bool
}
type JoinFun a = OldFact a -> NewFact a -> (ChangeFlag, a)
newtype OldFact a = OldFact a
newtype NewFact a = NewFact a
data ChangeFlag = NoChange | SomeChange
changeIf :: Bool -> ChangeFlag
changeIf changed = if changed then SomeChange else NoChange
data FwdPass n f
= FwdPass { fp_lattice :: DataflowLattice f
, fp_transfer :: FwdTransfer n f
, fp_rewrite :: FwdRewrite n f }
type FwdTransfer n f
= forall e x. n e x -> Fact e f -> Fact x f
type FwdRewrite n f
= forall e x. n e x -> Fact e f -> Maybe (FwdRes n f e x)
data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f)
type family Fact x f :: *
type instance Fact C f = FactBase f
type instance Fact O f = f
type SimpleFwdRewrite n f
= forall e x. n e x -> Fact e f
-> Maybe (AGraph n e x)
noFwdRewrite :: FwdRewrite n f
noFwdRewrite _ _ = Nothing
shallowFwdRw :: SimpleFwdRewrite n f -> FwdRewrite n f
shallowFwdRw rw n f = case (rw n f) of
Nothing -> Nothing
Just ag -> Just (FwdRes ag noFwdRewrite)
thenFwdRw :: FwdRewrite n f -> FwdRewrite n f -> FwdRewrite n f
thenFwdRw rw1 rw2 n f
= case rw1 n f of
Nothing -> rw2 n f
Just (FwdRes ag rw1a) -> Just (FwdRes ag (rw1a `thenFwdRw` rw2))
deepFwdRw :: FwdRewrite n f -> FwdRewrite n f
deepFwdRw rw =
\ n f -> case rw n f of
Just (FwdRes g rw2) -> Just $ FwdRes g (rw2 `thenFwdRw` deepFwdRw rw)
Nothing -> Nothing
analyzeAndRewriteFwd
:: forall n f. Edges n
=> FwdPass n f
-> Body n -> FactBase f
-> FuelMonad (Body n, FactBase f)
analyzeAndRewriteFwd pass body facts
= do { (rg, _) <- arfBody pass body facts
; return (normaliseBody rg) }
type ARF thing n
= forall f e x. FwdPass n f -> thing e x
-> Fact e f -> FuelMonad (RG n f e x, Fact x f)
arfNode :: Edges n => ARF n n
arfNode pass node f
= do { mb_g <- withFuel (fp_rewrite pass node f)
; case mb_g of
Nothing -> return (RGUnit f (BUnit node),
fp_transfer pass node f)
Just (FwdRes ag rw) -> do { g <- graphOfAGraph ag
; let pass' = pass { fp_rewrite = rw }
; arfGraph pass' g f } }
arfBlock :: Edges n => ARF (Block n) n
arfBlock pass (BUnit node) f = arfNode pass node f
arfBlock pass (BCat hd mids) f = do { (g1,f1) <- arfBlock pass hd f
; (g2,f2) <- arfBlock pass mids f1
; return (g1 `RGCatO` g2, f2) }
arfBody :: Edges n
=> FwdPass n f -> Body n -> FactBase f
-> FuelMonad (RG n f C C, FactBase f)
arfBody pass blocks init_fbase
= fixpoint True (fp_lattice pass) (arfBlock pass) init_fbase $
forwardBlockList (factBaseLabels init_fbase) blocks
arfGraph :: Edges n => ARF (Graph n) n
arfGraph _ GNil f = return (RGNil, f)
arfGraph pass (GUnit blk) f = arfBlock pass blk f
arfGraph pass (GMany NothingO body NothingO) f
= do { (body', fb) <- arfBody pass body f
; return (body', fb) }
arfGraph pass (GMany NothingO body (JustO exit)) f
= do { (body', fb) <- arfBody pass body f
; (exit', fx) <- arfBlock pass exit fb
; return (body' `RGCatC` exit', fx) }
arfGraph pass (GMany (JustO entry) body NothingO) f
= do { (entry', fe) <- arfBlock pass entry f
; (body', fb) <- arfBody pass body fe
; return (entry' `RGCatC` body', fb) }
arfGraph pass (GMany (JustO entry) body (JustO exit)) f
= do { (entry', fe) <- arfBlock pass entry f
; (body', fb) <- arfBody pass body fe
; (exit', fx) <- arfBlock pass exit fb
; return (entry' `RGCatC` body' `RGCatC` exit', fx) }
forwardBlockList :: Edges n => [Label] -> Body n -> [((Label,Block n C C), [Label])]
forwardBlockList _ blks = map withLbl $ bodyList blks
where withLbl (l, b) = ((l, b), [l])
data BwdPass n f
= BwdPass { bp_lattice :: DataflowLattice f
, bp_transfer :: BwdTransfer n f
, bp_rewrite :: BwdRewrite n f }
type BwdTransfer n f
= forall e x. n e x -> Fact x f -> Fact e f
type BwdRewrite n f
= forall e x. n e x -> Fact x f -> Maybe (BwdRes n f e x)
data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite n f)
type SimpleBwdRewrite n f
= forall e x. n e x -> Fact x f
-> Maybe (AGraph n e x)
noBwdRewrite :: BwdRewrite n f
noBwdRewrite _ _ = Nothing
shallowBwdRw :: SimpleBwdRewrite n f -> BwdRewrite n f
shallowBwdRw rw n f = case (rw n f) of
Nothing -> Nothing
Just ag -> Just (BwdRes ag noBwdRewrite)
thenBwdRw :: BwdRewrite n f -> BwdRewrite n f -> BwdRewrite n f
thenBwdRw rw1 rw2 n f
= case rw1 n f of
Nothing -> rw2 n f
Just (BwdRes ag rw1a) -> Just (BwdRes ag (rw1a `thenBwdRw` rw2))
deepBwdRw :: BwdRewrite n f -> BwdRewrite n f
deepBwdRw rw = rw `thenBwdRw` deepBwdRw rw
type ARB thing n
= forall f e x. BwdPass n f -> thing e x
-> Fact x f -> FuelMonad (RG n f e x, Fact e f)
arbNode :: Edges n => ARB n n
arbNode pass node f
= do { mb_g <- withFuel (bp_rewrite pass node f)
; case mb_g of
Nothing -> return (RGUnit entry_f (BUnit node), entry_f)
where
entry_f = bp_transfer pass node f
Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag
; let pass' = pass { bp_rewrite = rw }
; arbGraph pass' g f} }
arbBlock :: Edges n => ARB (Block n) n
arbBlock pass (BUnit node) f = arbNode pass node f
arbBlock pass (BCat b1 b2) f = do { (g2,f2) <- arbBlock pass b2 f
; (g1,f1) <- arbBlock pass b1 f2
; return (g1 `RGCatO` g2, f1) }
arbBody :: Edges n
=> BwdPass n f -> Body n -> FactBase f
-> FuelMonad (RG n f C C, FactBase f)
arbBody pass blocks init_fbase
= fixpoint False (bp_lattice pass) (arbBlock pass) init_fbase $
backwardBlockList (factBaseLabels init_fbase) blocks
arbGraph :: Edges n => ARB (Graph n) n
arbGraph _ GNil f = return (RGNil, f)
arbGraph pass (GUnit blk) f = arbBlock pass blk f
arbGraph pass (GMany NothingO body NothingO) f
= do { (body', fb) <- arbBody pass body f
; return (body', fb) }
arbGraph pass (GMany NothingO body (JustO exit)) f
= do { (exit', fx) <- arbBlock pass exit f
; (body', fb) <- arbBody pass body fx
; return (body' `RGCatC` exit', fb) }
arbGraph pass (GMany (JustO entry) body NothingO) f
= do { (body', fb) <- arbBody pass body f
; (entry', fe) <- arbBlock pass entry fb
; return (entry' `RGCatC` body', fe) }
arbGraph pass (GMany (JustO entry) body (JustO exit)) f
= do { (exit', fx) <- arbBlock pass exit f
; (body', fb) <- arbBody pass body fx
; (entry', fe) <- arbBlock pass entry fb
; return (entry' `RGCatC` body' `RGCatC` exit', fe) }
backwardBlockList :: Edges n => [Label] -> Body n -> [((Label, Block n C C), [Label])]
backwardBlockList _ blks = map withSuccs $ bodyList blks
where withSuccs (l, b) = ((l, b), successors b)
analyzeAndRewriteBwd
:: forall n f. Edges n
=> BwdPass n f
-> Body n -> FactBase f
-> FuelMonad (Body n, FactBase f)
analyzeAndRewriteBwd pass body facts
= do { (rg, _) <- arbBody pass body facts
; return (normaliseBody rg) }
data TxFactBase n f
= TxFB { tfb_fbase :: FactBase f
, tfb_rg :: RG n f C C
, tfb_cha :: ChangeFlag
, tfb_lbls :: LabelSet }
updateFact :: DataflowLattice f -> LabelSet -> (Label, f)
-> (ChangeFlag, FactBase f)
-> (ChangeFlag, FactBase f)
updateFact lat lbls (lbl, new_fact) (cha, fbase)
| NoChange <- cha2 = (cha, fbase)
| lbl `elemLabelSet` lbls = (SomeChange, new_fbase)
| otherwise = (cha, new_fbase)
where
(cha2, res_fact)
= case lookupFact fbase lbl of
Nothing -> (SomeChange, new_fact)
Just old_fact -> fact_extend lat (OldFact old_fact) (NewFact new_fact)
new_fbase = extendFactBase fbase lbl res_fact
fixpoint :: forall n f. Edges n
=> Bool
-> DataflowLattice f
-> (Block n C C -> FactBase f
-> FuelMonad (RG n f C C, FactBase f))
-> FactBase f -> [((Label, Block n C C), [Label])]
-> FuelMonad (RG n f C C, FactBase f)
fixpoint is_fwd lat do_block init_fbase blocks
= do { fuel <- getFuel
; tx_fb <- loop fuel init_fbase
; return (tfb_rg tx_fb,
tfb_fbase tx_fb `delFromFactBase` map fst blocks) }
where
tx_blocks :: [((Label, Block n C C), [Label])]
-> TxFactBase n f -> FuelMonad (TxFactBase n f)
tx_blocks [] tx_fb = return tx_fb
tx_blocks (((lbl,blk), deps):bs) tx_fb = tx_block lbl blk deps tx_fb >>= tx_blocks bs
tx_block :: Label -> Block n C C -> [Label]
-> TxFactBase n f -> FuelMonad (TxFactBase n f)
tx_block lbl blk deps tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls
, tfb_rg = blks, tfb_cha = cha })
| is_fwd && not (lbl `elemFactBase` fbase)
= return tx_fb {tfb_lbls = lbls `unionLabelSet` mkLabelSet deps}
| otherwise
= do { (rg, out_facts) <- do_block blk fbase
; let (cha',fbase')
= foldr (updateFact lat lbls) (cha,fbase)
(factBaseList out_facts)
lbls' = lbls `unionLabelSet` mkLabelSet deps
; return (TxFB { tfb_lbls = lbls'
, tfb_rg = rg `RGCatC` blks
, tfb_fbase = fbase', tfb_cha = cha' }) }
loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)
loop fuel fbase
= do { let init_tx_fb = TxFB { tfb_fbase = fbase
, tfb_cha = NoChange
, tfb_rg = RGNil
, tfb_lbls = emptyLabelSet }
; tx_fb <- tx_blocks blocks init_tx_fb
; case tfb_cha tx_fb of
NoChange -> return tx_fb
SomeChange -> do { setFuel fuel
; loop fuel (tfb_fbase tx_fb) } }
data RG n f e x where
RGNil :: RG n f a a
RGUnit :: Fact e f -> Block n e x -> RG n f e x
RGCatO :: RG n f e O -> RG n f O x -> RG n f e x
RGCatC :: RG n f e C -> RG n f C x -> RG n f e x
type BodyWithFacts n f = (Body n, FactBase f)
type GraphWithFacts n f e x = (Graph n e x, FactBase f)
normaliseBody :: Edges n => RG n f C C -> BodyWithFacts n f
normaliseBody rg = (body, fact_base)
where
(GMany _ body _, fact_base) = normCC rg
normOO :: Edges n => RG n f O O -> GraphWithFacts n f O O
normOO RGNil = (GNil, noFacts)
normOO (RGUnit _ b) = (GUnit b, noFacts)
normOO (RGCatO g1 g2) = normOO g1 `gwfCat` normOO g2
normOO (RGCatC g1 g2) = normOC g1 `gwfCat` normCO g2
normOC :: Edges n => RG n f O C -> GraphWithFacts n f O C
normOC (RGUnit _ b) = (GMany (JustO b) BodyEmpty NothingO, noFacts)
normOC (RGCatO g1 g2) = normOO g1 `gwfCat` normOC g2
normOC (RGCatC g1 g2) = normOC g1 `gwfCat` normCC g2
normCO :: Edges n => RG n f C O -> GraphWithFacts n f C O
normCO (RGUnit f b) = (GMany NothingO BodyEmpty (JustO b), unitFact l f)
where
l = entryLabel b
normCO (RGCatO g1 g2) = normCO g1 `gwfCat` normOO g2
normCO (RGCatC g1 g2) = normCC g1 `gwfCat` normCO g2
normCC :: Edges n => RG n f C C -> GraphWithFacts n f C C
normCC RGNil = (GMany NothingO BodyEmpty NothingO, noFacts)
normCC (RGUnit f b) = (GMany NothingO (BodyUnit b) NothingO, unitFact l f)
where
l = entryLabel b
normCC (RGCatO g1 g2) = normCO g1 `gwfCat` normOC g2
normCC (RGCatC g1 g2) = normCC g1 `gwfCat` normCC g2
gwfCat :: Edges n => GraphWithFacts n f e a
-> GraphWithFacts n f a x
-> GraphWithFacts n f e x
gwfCat (g1, fb1) (g2, fb2) = (g1 `gCat` g2, fb1 `unionFactBase` fb2)
graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
graphOfAGraph ag = ag
gCat :: Graph n e a -> Graph n a x -> Graph n e x
gCat = U.gCatAny