Commit 02f2f21c authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari
Browse files

cmm/Hoopl/Dataflow: remove unused code



We had *a lot* of code copied from Hoopl that is for rewriting. But GHC
doesn't use it (it only uses some forked Hoopl code for analysis).

So we can safely kill all this code and make it much easier to refactor
and improve the parts that we do use.
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan: ./validate

Reviewers: austin, simonmar, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2612
parent 3866481f
...@@ -58,8 +58,8 @@ module CmmUtils( ...@@ -58,8 +58,8 @@ module CmmUtils(
toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1, foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
analFwd, analBwd, analRewFwd, analRewBwd, analFwd, analBwd,
dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd, dataflowAnalFwd, dataflowAnalBwd,
dataflowAnalFwdBlocks, dataflowAnalFwdBlocks,
-- * Ticks -- * Ticks
...@@ -565,30 +565,10 @@ postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g ...@@ -565,30 +565,10 @@ postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g
analFwd :: DataflowLattice f -> FwdTransfer n f -> FwdPass UniqSM n f analFwd :: DataflowLattice f -> FwdTransfer n f -> FwdPass UniqSM n f
analBwd :: DataflowLattice f -> BwdTransfer n f -> BwdPass UniqSM n f analBwd :: DataflowLattice f -> BwdTransfer n f -> BwdPass UniqSM n f
analFwd lat xfer = analRewFwd lat xfer noFwdRewrite analFwd lat xfer =
analBwd lat xfer = analRewBwd lat xfer noBwdRewrite FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = noFwdRewrite}
analBwd lat xfer =
-- Constructing forward and backward analysis + rewrite pass BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = noBwdRewrite}
analRewFwd :: DataflowLattice f -> FwdTransfer n f
-> FwdRewrite UniqSM n f
-> FwdPass UniqSM n f
analRewBwd :: DataflowLattice f
-> BwdTransfer n f
-> BwdRewrite UniqSM n f
-> BwdPass UniqSM n f
analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
-- Running forward and backward dataflow analysis + optional rewrite
dataflowPassFwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> FwdPass UniqSM n f
-> UniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
(graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
dataflowAnalFwd :: NonLocal n => dataflowAnalFwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)] GenCmmGraph n -> [(BlockId, f)]
...@@ -613,14 +593,6 @@ dataflowAnalBwd :: NonLocal n => ...@@ -613,14 +593,6 @@ dataflowAnalBwd :: NonLocal n =>
dataflowAnalBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = dataflowAnalBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd =
analyzeBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts) analyzeBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
dataflowPassBwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> BwdPass UniqSM n f
-> UniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
(graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
------------------------------------------------- -------------------------------------------------
-- Tick utilities -- Tick utilities
......
...@@ -3,9 +3,6 @@ ...@@ -3,9 +3,6 @@
module Hoopl ( module Hoopl (
module Compiler.Hoopl, module Compiler.Hoopl,
module Hoopl.Dataflow, module Hoopl.Dataflow,
deepFwdRw, deepFwdRw3,
deepBwdRw, deepBwdRw3,
thenFwdRw
) where ) where
import Compiler.Hoopl hiding import Compiler.Hoopl hiding
...@@ -23,109 +20,6 @@ import Compiler.Hoopl hiding ...@@ -23,109 +20,6 @@ import Compiler.Hoopl hiding
) )
import Hoopl.Dataflow import Hoopl.Dataflow
import Control.Monad
import UniqSupply
deepFwdRw3 :: (n C O -> f -> UniqSM (Maybe (Graph n C O)))
-> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
-> (n O C -> f -> UniqSM (Maybe (Graph n O C)))
-> (FwdRewrite UniqSM n f)
deepFwdRw :: (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x))) -> FwdRewrite UniqSM n f
deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l
deepFwdRw f = deepFwdRw3 f f f
-- N.B. rw3, rw3', and rw3a are triples of functions.
-- But rw and rw' are single functions.
thenFwdRw :: forall n f.
FwdRewrite UniqSM n f
-> FwdRewrite UniqSM n f
-> FwdRewrite UniqSM n f
thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3'
where
thenrw :: forall e x t t1.
(t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
-> (t -> t1 -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
-> t
-> t1
-> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))
thenrw rw rw' n f = rw n f >>= fwdRes
where fwdRes Nothing = rw' n f
fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr
iterFwdRw :: forall n f.
FwdRewrite UniqSM n f
-> FwdRewrite UniqSM n f
iterFwdRw rw3 = wrapFR iter rw3
where iter :: forall a e x t.
(t -> a -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
-> t
-> a
-> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f))
iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n
-- | Function inspired by 'rew' in the paper
_frewrite_cps :: ((Graph n e x, FwdRewrite UniqSM n f) -> UniqSM a)
-> UniqSM a
-> (forall e x . n e x -> f -> UniqSM (Maybe (Graph n e x, FwdRewrite UniqSM n f)))
-> n e x
-> f
-> UniqSM a
_frewrite_cps j n rw node f =
do mg <- rw node f
case mg of Nothing -> n
Just gr -> j gr
-- | Function inspired by 'add' in the paper
fadd_rw :: FwdRewrite UniqSM n f
-> (Graph n e x, FwdRewrite UniqSM n f)
-> (Graph n e x, FwdRewrite UniqSM n f)
fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2)
deepBwdRw3 ::
(n C O -> f -> UniqSM (Maybe (Graph n C O)))
-> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
-> (n O C -> FactBase f -> UniqSM (Maybe (Graph n O C)))
-> (BwdRewrite UniqSM n f)
deepBwdRw :: (forall e x . n e x -> Fact x f -> UniqSM (Maybe (Graph n e x)))
-> BwdRewrite UniqSM n f
deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l
deepBwdRw f = deepBwdRw3 f f f
thenBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f
thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2
where f :: forall t t1 t2 e x.
t
-> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
-> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
-> t1
-> t2
-> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))
f _ rw1 rw2' n f = do
res1 <- rw1 n f
case res1 of
Nothing -> rw2' n f
Just gr -> return $ Just $ badd_rw rw2 gr
iterBwdRw :: forall n f. BwdRewrite UniqSM n f -> BwdRewrite UniqSM n f
iterBwdRw rw = wrapBR f rw
where f :: forall t e x t1 t2.
t
-> (t1 -> t2 -> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f)))
-> t1
-> t2
-> UniqSM (Maybe (Graph n e x, BwdRewrite UniqSM n f))
f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f)
-- | Function inspired by 'add' in the paper
badd_rw :: BwdRewrite UniqSM n f
-> (Graph n e x, BwdRewrite UniqSM n f)
-> (Graph n e x, BwdRewrite UniqSM n f)
badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2)
-- Note [Deprecations in Hoopl] -- Note [Deprecations in Hoopl]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
...@@ -21,36 +21,20 @@ module Hoopl.Dataflow ...@@ -21,36 +21,20 @@ module Hoopl.Dataflow
( DataflowLattice(..), OldFact(..), NewFact(..), Fact, mkFactBase ( DataflowLattice(..), OldFact(..), NewFact(..), Fact, mkFactBase
, ChangeFlag(..) , ChangeFlag(..)
, FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3 , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3
-- * Respecting Fuel
-- $fuel
, FwdRewrite, mkFRewrite, mkFRewrite3, getFRewrite3, noFwdRewrite
, wrapFR, wrapFR2
, BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3 , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3
, wrapBR, wrapBR2
, BwdRewrite, mkBRewrite, mkBRewrite3, getBRewrite3, noBwdRewrite , noBwdRewrite, noFwdRewrite
, analyzeAndRewriteFwd, analyzeAndRewriteBwd
, analyzeFwd, analyzeFwdBlocks, analyzeBwd , analyzeFwd, analyzeFwdBlocks, analyzeBwd
) )
where where
import UniqSupply import UniqSupply
import Data.Maybe
import Data.Array import Data.Array
import Compiler.Hoopl hiding import Compiler.Hoopl hiding (noFwdRewrite, noBwdRewrite)
( mkBRewrite3, mkFRewrite3, noFwdRewrite, noBwdRewrite
, analyzeAndRewriteBwd, analyzeAndRewriteFwd
)
import Compiler.Hoopl.Internals
( wrapFR, wrapFR2
, wrapBR, wrapBR2
, splice
)
-- -----------------------------------------------------------------------------
noRewrite :: a -> b -> UniqSM (Maybe c) noRewrite :: a -> b -> UniqSM (Maybe c)
noRewrite _ _ = return Nothing noRewrite _ _ = return Nothing
...@@ -58,173 +42,9 @@ noRewrite _ _ = return Nothing ...@@ -58,173 +42,9 @@ noRewrite _ _ = return Nothing
noFwdRewrite :: FwdRewrite UniqSM n f noFwdRewrite :: FwdRewrite UniqSM n f
noFwdRewrite = FwdRewrite3 (noRewrite, noRewrite, noRewrite) noFwdRewrite = FwdRewrite3 (noRewrite, noRewrite, noRewrite)
-- | Functions passed to 'mkFRewrite3' should not be aware of the fuel supply.
-- The result returned by 'mkFRewrite3' respects fuel.
mkFRewrite3 :: forall n f.
(n C O -> f -> UniqSM (Maybe (Graph n C O)))
-> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
-> (n O C -> f -> UniqSM (Maybe (Graph n O C)))
-> FwdRewrite UniqSM n f
mkFRewrite3 f m l = FwdRewrite3 (lift f, lift m, lift l)
where lift :: forall t t1 a. (t -> t1 -> UniqSM (Maybe a))
-> t -> t1 -> UniqSM (Maybe (a, FwdRewrite UniqSM n f))
{-# INLINE lift #-}
lift rw node fact = do
a <- rw node fact
case a of
Nothing -> return Nothing
Just a -> return (Just (a,noFwdRewrite))
noBwdRewrite :: BwdRewrite UniqSM n f noBwdRewrite :: BwdRewrite UniqSM n f
noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite) noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite)
mkBRewrite3 :: forall n f.
(n C O -> f -> UniqSM (Maybe (Graph n C O)))
-> (n O O -> f -> UniqSM (Maybe (Graph n O O)))
-> (n O C -> FactBase f -> UniqSM (Maybe (Graph n O C)))
-> BwdRewrite UniqSM n f
mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l)
where lift :: forall t t1 a. (t -> t1 -> UniqSM (Maybe a))
-> t -> t1 -> UniqSM (Maybe (a, BwdRewrite UniqSM n f))
{-# INLINE lift #-}
lift rw node fact = do
a <- rw node fact
case a of
Nothing -> return Nothing
Just a -> return (Just (a,noBwdRewrite))
-----------------------------------------------------------------------------
-- Analyze and rewrite forward: the interface
-----------------------------------------------------------------------------
-- | if the graph being analyzed is open at the entry, there must
-- be no other entry point, or all goes horribly wrong...
analyzeAndRewriteFwd
:: forall n f e x . NonLocal n =>
FwdPass UniqSM n f
-> MaybeC e [Label]
-> Graph n e x -> Fact e f
-> UniqSM (Graph n e x, FactBase f, MaybeO x f)
analyzeAndRewriteFwd pass entries g f =
do (rg, fout) <- arfGraph pass (fmap targetLabels entries) g f
let (g', fb) = normalizeGraph 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
----------------------------------------------------------------
-- Forward Implementation
----------------------------------------------------------------
type Entries e = MaybeC e [Label]
arfGraph :: forall n f e x . NonLocal n =>
FwdPass UniqSM n f ->
Entries e -> Graph n e x -> Fact e f -> UniqSM (DG f n e x, Fact x f)
arfGraph pass@FwdPass { fp_lattice = lattice,
fp_transfer = transfer,
fp_rewrite = rewrite } entries g in_fact = graph g in_fact
where
{- nested type synonyms would be so lovely here
type ARF thing = forall e x . thing e x -> f -> m (DG f n e x, Fact x f)
type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f)
-}
graph :: Graph n e x -> Fact e f -> UniqSM (DG f n e x, Fact x f)
block :: forall e x .
Block n e x -> f -> UniqSM (DG f n e x, Fact x f)
body :: [Label] -> LabelMap (Block n C C)
-> Fact C f -> UniqSM (DG f n C C, Fact C f)
-- Outgoing factbase is restricted to Labels *not* in
-- in the Body; the facts for Labels *in*
-- the Body are in the 'DG f n C C'
cat :: forall e a x f1 f2 f3.
(f1 -> UniqSM (DG f n e a, f2))
-> (f2 -> UniqSM (DG f n a x, f3))
-> (f1 -> UniqSM (DG f n e x, f3))
graph GNil f = return (dgnil, f)
graph (GUnit blk) f = block blk f
graph (GMany e bdy x) f = ((e `ebcat` bdy) `cat` exit x) f
where
ebcat :: MaybeO e (Block n O C) -> Body n -> Fact e f -> UniqSM (DG f n e C, Fact C f)
exit :: MaybeO x (Block n C O) -> Fact C f -> UniqSM (DG f n C x, Fact x f)
exit (JustO blk) f = arfx block blk f
exit NothingO f = return (dgnilC, f)
ebcat entry bdy f = c entries entry f
where c :: MaybeC e [Label] -> MaybeO e (Block n O C)
-> Fact e f -> UniqSM (DG f n e C, Fact C f)
c NothingC (JustO entry) f = (block entry `cat` body (successors entry) bdy) f
c (JustC entries) NothingO f = body entries bdy f
-- Lift from nodes to blocks
block BNil f = return (dgnil, f)
block (BlockCO n b) f = (node n `cat` block b) f
block (BlockCC l b n) f = (node l `cat` block b `cat` node n) f
block (BlockOC b n) f = (block b `cat` node n) f
block (BMiddle n) f = node n f
block (BCat b1 b2) f = (block b1 `cat` block b2) f
block (BSnoc h n) f = (block h `cat` node n) f
block (BCons n t) f = (node n `cat` block t) f
{-# INLINE node #-}
node :: forall e x . (ShapeLifter e x)
=> n e x -> f -> UniqSM (DG f n e x, Fact x f)
node n f
= do { grw <- frewrite rewrite n f
; case grw of
Nothing -> return ( singletonDG f n
, ftransfer transfer n f )
Just (g, rw) ->
let pass' = pass { fp_rewrite = rw }
f' = fwdEntryFact n f
in arfGraph pass' (fwdEntryLabel n) g f' }
-- | Compose fact transformers and concatenate the resulting
-- rewritten graphs.
{-# INLINE cat #-}
cat ft1 ft2 f = do { (g1,f1) <- ft1 f
; (g2,f2) <- ft2 f1
; let !g = g1 `dgSplice` g2
; return (g, f2) }
arfx :: forall x .
(Block n C x -> f -> UniqSM (DG f n C x, Fact x f))
-> (Block n C x -> Fact C f -> UniqSM (DG f n C x, Fact x f))
arfx arf thing fb =
arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb
-- joinInFacts adds debugging information
-- Outgoing factbase is restricted to Labels *not* in
-- in the Body; the facts for Labels *in*
-- the Body are in the 'DG f n C C'
body entries blockmap init_fbase
= fixpoint Fwd lattice do_block entries blockmap init_fbase
where
lattice = fp_lattice pass
do_block :: forall x . Block n C x -> FactBase f
-> UniqSM (DG f n C x, Fact x f)
do_block b fb = block b entryFact
where entryFact = getFact lattice (entryLabel b) fb
-- Join all the incoming facts with bottom.
-- We know the results _shouldn't change_, but the transfer
-- functions might, for example, generate some debugging traces.
joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f
joinInFacts (lattice @ DataflowLattice {fact_bot = bot, fact_join = fj}) fb =
mkFactBase lattice $ map botJoin $ mapToList fb
where botJoin (l, f) = (l, snd $ fj l (OldFact bot) (NewFact f))
forwardBlockList :: (NonLocal n) forwardBlockList :: (NonLocal n)
=> [Label] -> Body n -> [Block n C C] => [Label] -> Body n -> [Block n C C]
-- This produces a list of blocks in order suitable for forward analysis, -- This produces a list of blocks in order suitable for forward analysis,
...@@ -360,123 +180,6 @@ analyzeBwd BwdPass { bp_lattice = lattice, ...@@ -360,123 +180,6 @@ analyzeBwd BwdPass { bp_lattice = lattice,
cat :: forall f1 f2 f3 . (f2 -> f3) -> (f1 -> f2) -> (f1 -> f3) cat :: forall f1 f2 f3 . (f2 -> f3) -> (f1 -> f2) -> (f1 -> f3)
cat ft1 ft2 = \f -> ft1 $! ft2 f cat ft1 ft2 = \f -> ft1 $! ft2 f
-----------------------------------------------------------------------------
-- Backward analysis and rewriting: the interface
-----------------------------------------------------------------------------
-- | if the graph being analyzed is open at the exit, I don't
-- quite understand the implications of possible other exits
analyzeAndRewriteBwd
:: NonLocal n
=> BwdPass UniqSM n f
-> MaybeC e [Label] -> Graph n e x -> Fact x f
-> UniqSM (Graph n e x, FactBase f, MaybeO e f)
analyzeAndRewriteBwd pass entries g f =
do (rg, fout) <- arbGraph pass (fmap targetLabels entries) g f
let (g', fb) = normalizeGraph 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
-----------------------------------------------------------------------------
-- Backward implementation
-----------------------------------------------------------------------------
arbGraph :: forall n f e x .
NonLocal n =>
BwdPass UniqSM n f ->
Entries e -> Graph n e x -> Fact x f -> UniqSM (DG f n e x, Fact e f)
arbGraph pass@BwdPass { bp_lattice = lattice,
bp_transfer = transfer,
bp_rewrite = rewrite } entries g in_fact = graph g in_fact
where
{- nested type synonyms would be so lovely here
type ARB thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f)
type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f)
-}
graph :: Graph n e x -> Fact x f -> UniqSM (DG f n e x, Fact e f)
block :: forall e x . Block n e x -> Fact x f -> UniqSM (DG f n e x, f)
body :: [Label] -> Body n -> Fact C f -> UniqSM (DG f n C C, Fact C f)
node :: forall e x . (ShapeLifter e x)
=> n e x -> Fact x f -> UniqSM (DG f n e x, f)
cat :: forall e a x info info' info''.
(info' -> UniqSM (DG f n e a, info''))
-> (info -> UniqSM (DG f n a x, info'))
-> (info -> UniqSM (DG f n e x, info''))
graph GNil f = return (dgnil, f)
graph (GUnit blk) f = block blk f
graph (GMany e bdy x) f = ((e `ebcat` bdy) `cat` exit x) f
where
ebcat :: MaybeO e (Block n O C) -> Body n -> Fact C f -> UniqSM (DG f n e C, Fact e f)
exit :: MaybeO x (Block n C O) -> Fact x f -> UniqSM (DG f n C x, Fact C f)
exit (JustO blk) f = arbx block blk f
exit NothingO f = return (dgnilC, f)
ebcat entry bdy f = c entries entry f
where c :: MaybeC e [Label] -> MaybeO e (Block n O C)
-> Fact C f -> UniqSM (DG f n e C, Fact e f)
c NothingC (JustO entry) f = (block entry `cat` body (successors entry) bdy) f
c (JustC entries) NothingO f = body entries bdy f
-- Lift from nodes to blocks
block BNil f = return (dgnil, f)
block (BlockCO n b) f = (node n `cat` block b) f
block (BlockCC l b n) f = (node l `cat` block b `cat` node n) f
block (BlockOC b n) f = (block b `cat` node n) f
block (BMiddle n) f = node n f
block (BCat b1 b2) f = (block b1 `cat` block b2) f
block (BSnoc h n) f = (block h `cat` node n) f
block (BCons n t) f = (node n `cat` block t) f
{-# INLINE node #-}
node n f
= do { bwdres <- brewrite rewrite n f
; case bwdres of
Nothing -> return (singletonDG entry_f n, entry_f)
where entry_f = btransfer transfer n f
Just (g, rw) ->
do { let pass' = pass { bp_rewrite = rw }
; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f
; return (g, bwdEntryFact lattice n f)} }
-- | Compose fact transformers and concatenate the resulting
-- rewritten graphs.
{-# INLINE cat #-}
cat ft1 ft2 f = do { (g2,f2) <- ft2 f
; (g1,f1) <- ft1 f2
; let !g = g1 `dgSplice` g2
; return (g, f1) }
arbx :: forall x .
(Block n C x -> Fact x f -> UniqSM (DG f n C x, f))
-> (Block n C x -> Fact x f -> UniqSM (DG f n C x, Fact C f))
arbx arb thing f = do { (rg, f) <- arb thing f
; let fb = joinInFacts (bp_lattice pass) $
mapSingleton (entryLabel thing) f
; return (rg, fb) }
-- joinInFacts adds debugging information
-- Outgoing factbase is restricted to Labels *not* in
-- in the Body; the facts for Labels *in*
-- the Body are in the 'DG f n C C'
body entries blockmap init_fbase
= fixpoint Bwd (bp_lattice pass) do_block entries blockmap init_fbase
where
do_block :: forall x. Block n C x -> Fact x f -> UniqSM (DG f n C x, LabelMap f)
do_block b f = do (g, f) <- block b f
return (g, mapSingleton (entryLabel b) f)
{- {-
The forward and backward cases are not dual. In the forward case, the The forward and backward cases are not dual. In the forward case, the
...@@ -541,95 +244,7 @@ fixpointAnal direction DataflowLattice{ fact_bot = _, fact_join = join } ...@@ -541,95 +244,7 @@ fixpointAnal direction DataflowLattice{ fact_bot = _, fact_join = join }
loop todo' fbase' loop todo' fbase'
-- | fixpointing for combined analysis/rewriting {-
--
fixpoint :: forall n f. NonLocal n
=> Direction
-> DataflowLattice f
-> (Block n C C -> Fact C f -> UniqSM (DG f n C C, Fact C f))
-> [Label]
-> LabelMap (Block n C C)
-> (Fact C f -> UniqSM (DG f n C C, Fact C f))
fixpoint direction DataflowLattice{ fact_bot = _, fact_join = join }
do_block entries blockmap init_fbase
= do
-- trace ("fixpoint: " ++ show (case direction of Fwd -> True; Bwd -> False) ++ " " ++ show (mapKeys blockmap) ++ show entries ++ " " ++ show (mapKeys init_fbase)) $ return()
(fbase, newblocks) <- loop start init_fbase mapEmpty
-- trace ("fixpoint DONE: " ++ show (mapKeys fbase) ++ show (mapKeys newblocks)) $ return()
return (GMany NothingO newblocks NothingO,