module Compiler.Hoopl.ZipDataflowNoRG
( FwdPass(..), FwdTransfer, FwdRewrite, FwdRes(..)
, BwdPass(..), BwdTransfer, BwdRewrite, BwdRes(..)
, analyzeAndRewriteFwd, analyzeAndRewriteBwd
, analyzeAndRewriteFwd', analyzeAndRewriteBwd'
)
where
import Compiler.Hoopl.Dataflow
( DataflowLattice(..), OldFact(..), NewFact(..)
, ChangeFlag(..)
, Fact
)
import Compiler.Hoopl.Fuel
import Compiler.Hoopl.Graph
import qualified Compiler.Hoopl.GraphUtil as U
import Compiler.Hoopl.Label
import Compiler.Hoopl.Util
import Compiler.Hoopl.Zipper
type AGraph n e x = FuelMonad (ZGraph n e x)
graphOfAGraph :: AGraph n e x -> FuelMonad (ZGraph n e x)
graphOfAGraph = id
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)
analyzeAndRewriteFwd
:: forall n f. Edges n
=> FwdPass n f
-> ZBody n -> FactBase f
-> FuelMonad (ZBody 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
-> ZGraph n e x -> Fact e f
-> FuelMonad (ZGraph n e x, FactBase f, MaybeO x f)
analyzeAndRewriteFwd' pass g f =
do (rg, fout) <- arfGraph pass g f
let (g', fb) = normalizeGraph rg
return (g', fb, distinguishedExitFact g' fout)
distinguishedExitFact :: forall n e x f . ZGraph n e x -> Fact x f -> MaybeO x f
distinguishedExitFact g f = maybe g
where maybe :: ZGraph 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
type ARF' n f thing e x
= FwdPass n f -> thing e x -> Fact e f -> FuelMonad (RG f n e x, Fact x f)
type ARF thing n = forall f e x . ARF' n f thing e x
arfNode :: Edges n
=> (n e x -> ZBlock n e x)
-> ARF' n f n e x
arfNode bunit 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' n f (ZBlock n) e x
_arfBlock = arfBlock
_arfGraph :: Edges n => ARF' n f (ZGraph n) e x
_arfGraph = arfGraph
arfMiddle :: Edges n => ARF' n f n O O
arfMiddle = arfNode ZMiddle
arfBlock :: Edges n => ARF (ZBlock n) n
arfBlock pass (ZFirst node) = arfNode ZFirst pass node
arfBlock pass (ZMiddle node) = arfNode ZMiddle pass node
arfBlock pass (ZLast node) = arfNode ZLast pass node
arfBlock pass (ZCat b1 b2) = arfCat arfBlock arfBlock pass b1 b2
arfBlock pass (ZHead h n) = arfCat arfBlock arfMiddle pass h n
arfBlock pass (ZTail n t) = arfCat arfMiddle arfBlock pass n t
arfBlock pass (ZClosed h t) = arfCat arfBlock arfBlock pass h t
arfCat :: Edges n => ARF' n f thing1 e O -> ARF' n f thing2 O x
-> FwdPass n f -> thing1 e O -> thing2 O x
-> Fact e f -> FuelMonad (RG f n e x, Fact x f)
arfCat arf1 arf2 pass thing1 thing2 f = do { (g1,f1) <- arf1 pass thing1 f
; (g2,f2) <- arf2 pass thing2 f1
; return (g1 `rgCat` g2, f2) }
arfBody :: Edges n
=> FwdPass n f -> ZBody n -> FactBase f
-> FuelMonad (RG f n 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 (ZGraph 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' `rgCat` 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' `rgCat` 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' `rgCat` body' `rgCat` exit', fx) }
forwardBlockList :: (Edges n, LabelsPtr entry)
=> entry -> ZBody n -> [ZBlock 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' n f thing e x
= BwdPass n f -> thing e x -> Fact x f -> FuelMonad (RG f n e x, Fact e f)
type ARB thing n = forall f e x. ARB' n f thing e x
arbNode :: Edges n
=> (n e x -> ZBlock n e x)
-> ARB' n f n e x
arbNode bunit 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} }
arbMiddle :: Edges n => ARB' n f n O O
arbMiddle = arbNode ZMiddle
arbBlock :: Edges n => ARB (ZBlock n) n
arbBlock pass (ZFirst node) = arbNode ZFirst pass node
arbBlock pass (ZMiddle node) = arbNode ZMiddle pass node
arbBlock pass (ZLast node) = arbNode ZLast pass node
arbBlock pass (ZCat b1 b2) = arbCat arbBlock arbBlock pass b1 b2
arbBlock pass (ZHead h n) = arbCat arbBlock arbMiddle pass h n
arbBlock pass (ZTail n t) = arbCat arbMiddle arbBlock pass n t
arbBlock pass (ZClosed h t) = arbCat arbBlock arbBlock pass h t
arbCat :: Edges n => ARB' n f thing1 e O -> ARB' n f thing2 O x
-> BwdPass n f -> thing1 e O -> thing2 O x
-> Fact x f -> FuelMonad (RG f n e x, Fact e f)
arbCat arb1 arb2 pass thing1 thing2 f = do { (g2,f2) <- arb2 pass thing2 f
; (g1,f1) <- arb1 pass thing1 f2
; return (g1 `rgCat` g2, f1) }
arbBody :: Edges n
=> BwdPass n f -> ZBody n -> FactBase f
-> FuelMonad (RG f n C C, FactBase f)
arbBody pass blocks init_fbase
= fixpoint False (bp_lattice pass) (arbBlock pass) init_fbase $
backwardBlockList blocks
arbGraph :: Edges n => ARB (ZGraph 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' `rgCat` 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' `rgCat` 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' `rgCat` body' `rgCat` exit', fe) }
backwardBlockList :: Edges n => ZBody n -> [ZBlock 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
-> ZBody n -> FactBase f
-> FuelMonad (ZBody 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
-> ZGraph n e x -> Fact x f
-> FuelMonad (ZGraph n e x, FactBase f, MaybeO e f)
analyzeAndRewriteBwd' pass g f =
do (rg, fout) <- arbGraph pass g f
let (g', fb) = normalizeGraph rg
return (g', fb, distinguishedEntryFact g' fout)
distinguishedEntryFact :: forall n e x f . ZGraph n e x -> Fact e f -> MaybeO e f
distinguishedEntryFact g f = maybe g
where maybe :: ZGraph 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 f n 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 block n f. Edges (block n)
=> Bool
-> DataflowLattice f
-> (block n C C -> FactBase f
-> FuelMonad (RG f n C C, FactBase f))
-> FactBase f
-> [block n C C]
-> FuelMonad (RG f n 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 `rgCat` 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 = rgnilC
, 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) } }
type RG f n e x = Graph' (FZBlock f) n e x
data FZBlock f n e x = FZBlock (Fact e f) (ZBlock n e x)
rgnil :: RG f n O O
rgnilC :: RG f n C C
rgunit :: Fact e f -> ZBlock n e x -> RG f n e x
rgCat :: RG f n e a -> RG f n a x -> RG f n e x
type BodyWithFacts n f = (ZBody n, FactBase f)
type GraphWithFacts n f e x = (ZGraph n e x, FactBase f)
normalizeGraph :: forall n f e x .
Edges n => RG f n e x -> GraphWithFacts n f e x
normaliseBody :: Edges n => RG f n C C -> BodyWithFacts n f
normalizeGraph g = (graphMapBlocks dropFact g, facts g)
where dropFact (FZBlock _ b) = b
facts :: RG f n e x -> FactBase f
facts GNil = noFacts
facts (GUnit _) = noFacts
facts (GMany _ body exit) = bodyFacts body `unionFactBase` exitFacts exit
exitFacts :: MaybeO x (FZBlock f n C O) -> FactBase f
exitFacts NothingO = noFacts
exitFacts (JustO (FZBlock f b)) = unitFact (entryLabel b) f
bodyFacts :: Body' (FZBlock f) n -> FactBase f
bodyFacts (BodyUnit (FZBlock f b)) = unitFact (entryLabel b) f
bodyFacts (b1 `BodyCat` b2) = bodyFacts b1 `unionFactBase` bodyFacts b2
normaliseBody rg = (body, fact_base)
where (GMany _ body _, fact_base) = normalizeGraph rg
rgnil = GNil
rgnilC = GMany NothingO BodyEmpty NothingO
rgunit f b@(ZFirst {}) = gUnitCO (FZBlock f b)
rgunit f b@(ZMiddle {}) = gUnitOO (FZBlock f b)
rgunit f b@(ZLast {}) = gUnitOC (FZBlock f b)
rgunit f b@(ZCat {}) = gUnitOO (FZBlock f b)
rgunit f b@(ZHead {}) = gUnitCO (FZBlock f b)
rgunit f b@(ZTail {}) = gUnitOC (FZBlock f b)
rgunit f b@(ZClosed {}) = gUnitCC (FZBlock f b)
rgCat = U.splice fzCat
where fzCat (FZBlock f b1) (FZBlock _ b2) = FZBlock f (b1 `U.zCat` b2)