module Compiler.Hoopl.Dataflow
( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..)
, ChangeFlag(..), changeIf
, FwdPass(..), FwdTransfer, FwdRewrite, FwdRes(..)
, BwdPass(..), BwdTransfer, BwdRewrite, BwdRes(..)
, Fact
, analyzeAndRewriteFwd, analyzeAndRewriteBwd
, 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, graphOfAGraph)
import Compiler.Hoopl.Util
data DataflowLattice a = DataflowLattice
{ fact_name :: String
, fact_bot :: a
, fact_extend :: JoinFun a
, fact_do_logging :: Bool
}
type JoinFun a = Label -> OldFact a -> NewFact a -> (ChangeFlag, a)
newtype OldFact a = OldFact a
newtype NewFact a = NewFact a
data ChangeFlag = NoChange | SomeChange deriving (Eq, Ord)
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
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) }
analyzeAndRewriteFwd'
:: forall n f e x. Edges n
=> FwdPass n f
-> Graph n e x -> Fact e f
-> FuelMonad (Graph n e x, FactBase f, MaybeO x f)
analyzeAndRewriteFwd' pass g f =
do (rg, fout) <- arfGraph pass g f
let (g', fb) = normalizeGraph g rg
return (g', fb, distinguishedExitFact g' fout)
distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f
distinguishedExitFact g f = maybe g
where maybe :: Graph n e x -> MaybeO x f
maybe GNil = JustO f
maybe (GUnit {}) = JustO f
maybe (GMany _ _ x) = case x of NothingO -> NothingO
JustO _ -> JustO f
normalizeGraph :: Edges n => Graph n e x -> RG n f e x -> GraphWithFacts n f e x
normalizeGraph GNil = normOO
normalizeGraph (GUnit {}) = normOO
normalizeGraph (GMany NothingO _ NothingO) = normCC
normalizeGraph (GMany (JustO _) _ NothingO) = normOC
normalizeGraph (GMany NothingO _ (JustO _)) = normCO
normalizeGraph (GMany (JustO _) _ (JustO _)) = normOO
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, LabelsPtr entry)
=> entry -> Body n -> [Block n C C]
forwardBlockList entries blks = postorder_dfs_from (bodyMap blks) entries
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 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 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 => Body n -> [Block n C C]
backwardBlockList body = reachable ++ missing
where reachable = reverse $ forwardBlockList entries body
entries = externalEntryLabels body
all = bodyList body
missingLabels =
mkLabelSet (map fst all) `minusLabelSet`
mkLabelSet (map entryLabel reachable)
missing = map snd $ filter (flip elemLabelSet missingLabels . fst) all
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) }
analyzeAndRewriteBwd'
:: forall n f e x. Edges n
=> BwdPass n f
-> Graph n e x -> Fact x f
-> FuelMonad (Graph n e x, FactBase f, MaybeO e f)
analyzeAndRewriteBwd' pass g f =
do (rg, fout) <- arbGraph pass g f
let (g', fb) = normalizeGraph g rg
return (g', fb, distinguishedEntryFact g' fout)
distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f
distinguishedEntryFact g f = maybe g
where maybe :: Graph n e x -> MaybeO e f
maybe GNil = JustO f
maybe (GUnit {}) = JustO f
maybe (GMany e _ _) = case e of NothingO -> NothingO
JustO _ -> JustO f
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, snd $ join $ fact_bot lat)
Just old_fact -> join old_fact
where join old_fact = fact_extend lat lbl (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
-> [Block n C C]
-> FuelMonad (RG n f C C, FactBase f)
fixpoint is_fwd lat do_block init_fbase untagged_blocks
= do { fuel <- getFuel
; tx_fb <- loop fuel init_fbase
; return (tfb_rg tx_fb,
tfb_fbase tx_fb `delFromFactBase` map fst blocks) }
where
blocks = map tag untagged_blocks
where tag b = ((entryLabel b, b), if is_fwd then [entryLabel b] else successors b)
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 `U.gSplice` g2, fb1 `unionFactBase` fb2)