summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/CmmUtils.hs40
-rw-r--r--compiler/cmm/Hoopl.hs106
-rw-r--r--compiler/cmm/Hoopl/Dataflow.hs530
3 files changed, 11 insertions, 665 deletions
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index b82f780c08..bce02fa948 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -58,8 +58,8 @@ module CmmUtils(
toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
- analFwd, analBwd, analRewFwd, analRewBwd,
- dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd,
+ analFwd, analBwd,
+ dataflowAnalFwd, dataflowAnalBwd,
dataflowAnalFwdBlocks,
-- * Ticks
@@ -565,30 +565,10 @@ postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g
analFwd :: DataflowLattice f -> FwdTransfer n f -> FwdPass UniqSM n f
analBwd :: DataflowLattice f -> BwdTransfer n f -> BwdPass UniqSM n f
-analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
-analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
-
--- Constructing forward and backward analysis + rewrite pass
-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)
+analFwd lat xfer =
+ FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = noFwdRewrite}
+analBwd lat xfer =
+ BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = noBwdRewrite}
dataflowAnalFwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
@@ -613,14 +593,6 @@ dataflowAnalBwd :: NonLocal n =>
dataflowAnalBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd =
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
diff --git a/compiler/cmm/Hoopl.hs b/compiler/cmm/Hoopl.hs
index 4b3717288f..b8acc5a3e6 100644
--- a/compiler/cmm/Hoopl.hs
+++ b/compiler/cmm/Hoopl.hs
@@ -3,9 +3,6 @@
module Hoopl (
module Compiler.Hoopl,
module Hoopl.Dataflow,
- deepFwdRw, deepFwdRw3,
- deepBwdRw, deepBwdRw3,
- thenFwdRw
) where
import Compiler.Hoopl hiding
@@ -23,109 +20,6 @@ import Compiler.Hoopl hiding
)
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]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index 1e3adf4726..a7475d2626 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -21,36 +21,20 @@ module Hoopl.Dataflow
( DataflowLattice(..), OldFact(..), NewFact(..), Fact, mkFactBase
, ChangeFlag(..)
, FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3
- -- * Respecting Fuel
- -- $fuel
- , FwdRewrite, mkFRewrite, mkFRewrite3, getFRewrite3, noFwdRewrite
- , wrapFR, wrapFR2
, BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3
- , wrapBR, wrapBR2
- , BwdRewrite, mkBRewrite, mkBRewrite3, getBRewrite3, noBwdRewrite
- , analyzeAndRewriteFwd, analyzeAndRewriteBwd
+
+ , noBwdRewrite, noFwdRewrite
+
, analyzeFwd, analyzeFwdBlocks, analyzeBwd
)
where
import UniqSupply
-import Data.Maybe
import Data.Array
-import Compiler.Hoopl hiding
- ( mkBRewrite3, mkFRewrite3, noFwdRewrite, noBwdRewrite
- , analyzeAndRewriteBwd, analyzeAndRewriteFwd
- )
-import Compiler.Hoopl.Internals
- ( wrapFR, wrapFR2
- , wrapBR, wrapBR2
- , splice
- )
-
-
--- -----------------------------------------------------------------------------
+import Compiler.Hoopl hiding (noFwdRewrite, noBwdRewrite)
noRewrite :: a -> b -> UniqSM (Maybe c)
noRewrite _ _ = return Nothing
@@ -58,173 +42,9 @@ noRewrite _ _ = return Nothing
noFwdRewrite :: FwdRewrite UniqSM n f
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 = 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)
=> [Label] -> Body n -> [Block n C C]
-- This produces a list of blocks in order suitable for forward analysis,
@@ -360,123 +180,6 @@ analyzeBwd BwdPass { bp_lattice = lattice,
cat :: forall f1 f2 f3 . (f2 -> f3) -> (f1 -> f2) -> (f1 -> f3)
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
@@ -541,95 +244,7 @@ fixpointAnal direction DataflowLattice{ fact_bot = _, fact_join = join }
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,
- mapDeleteList (mapKeys blockmap) fbase)
- -- The successors of the Graph are the the Labels
- -- for which we have facts and which are *not* in
- -- the blocks of the graph
- where
- blocks = sortBlocks direction entries blockmap
- n = length blocks
- block_arr = {-# SCC "block_arr" #-} listArray (0,n-1) blocks
- start = {-# SCC "start" #-} [0..n-1]
- dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
-
- loop
- :: IntHeap
- -> FactBase f -- current factbase (increases monotonically)
- -> LabelMap (DBlock f n C C) -- transformed graph
- -> UniqSM (FactBase f, LabelMap (DBlock f n C C))
-
- loop [] fbase newblocks = return (fbase, newblocks)
- loop (ix:todo) fbase !newblocks = do
- let blk = block_arr ! ix
-
- -- trace ("analysing: " ++ show (entryLabel blk)) $ return ()
- (rg, out_facts) <- do_block blk fbase
- let !(todo', fbase') =
- mapFoldWithKey (updateFact join dep_blocks)
- (todo,fbase) out_facts
-
- -- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()
- -- trace ("changed: " ++ show changed) $ return ()
- -- trace ("to analyse: " ++ show to_analyse) $ return ()
-
- let newblocks' = case rg of
- GMany _ blks _ -> mapUnion blks newblocks
-
- loop todo' fbase' newblocks'
-
-
-{- Note [TxFactBase invariants]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The TxFactBase is used only during a fixpoint iteration (or "sweep"),
-and accumulates facts (and the transformed code) during the fixpoint
-iteration.
-
-* tfb_fbase increases monotonically, across all sweeps
-
-* At the beginning of each sweep
- tfb_cha = NoChange
- tfb_lbls = {}
-
-* During each sweep we process each block in turn. Processing a block
- is done thus:
- 1. Read from tfb_fbase the facts for its entry label (forward)
- or successors labels (backward)
- 2. Transform those facts into new facts for its successors (forward)
- or entry label (backward)
- 3. Augment tfb_fbase with that info
- We call the labels read in step (1) the "in-labels" of the sweep
-
-* The field tfb_lbls is the set of in-labels of all blocks that have
- been processed so far this sweep, including the block that is
- currently being processed. tfb_lbls is initialised to {}. It is a
- subset of the Labels of the *original* (not transformed) blocks.
-
-* The tfb_cha field is set to SomeChange iff we decide we need to
- perform another iteration of the fixpoint loop. It is initialsed to NoChange.
-
- Specifically, we set tfb_cha to SomeChange in step (3) iff
- (a) The fact in tfb_fbase for a block L changes
- (b) L is in tfb_lbls
- Reason: until a label enters the in-labels its accumuated fact in tfb_fbase
- has not been read, hence cannot affect the outcome
-
+{-
Note [Unreachable blocks]
~~~~~~~~~~~~~~~~~~~~~~~~~
A block that is not in the domain of tfb_fbase is "currently unreachable".
@@ -720,150 +335,15 @@ we don't need to record a change. So there's a tradeoff here. It turns
out that always recording a change is faster.
-}
------------------------------------------------------------------------------
--- DG: an internal data type for 'decorated graphs'
--- TOTALLY internal to Hoopl; each block is decorated with a fact
------------------------------------------------------------------------------
-
-type DG f = Graph' (DBlock f)
-data DBlock f n e x = DBlock f (Block n e x) -- ^ block decorated with fact
-
-instance NonLocal n => NonLocal (DBlock f n) where
- entryLabel (DBlock _ b) = entryLabel b
- successors (DBlock _ b) = successors b
-
---- constructors
-
-dgnil :: DG f n O O
-dgnilC :: DG f n C C
-dgSplice :: NonLocal n => DG f n e a -> DG f n a x -> DG f n e x
-
----- observers
-
-normalizeGraph :: forall n f e x .
- NonLocal n => DG f n e x
- -> (Graph n e x, FactBase f)
- -- A Graph together with the facts for that graph
- -- The domains of the two maps should be identical
-
-normalizeGraph g = (mapGraphBlocks dropFact g, facts g)
- where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3
- dropFact (DBlock _ b) = b
- facts :: DG f n e x -> FactBase f
- facts GNil = noFacts
- facts (GUnit _) = noFacts
- facts (GMany _ body exit) = bodyFacts body `mapUnion` exitFacts exit
- exitFacts :: MaybeO x (DBlock f n C O) -> FactBase f
- exitFacts NothingO = noFacts
- exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f
- bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f
- bodyFacts body = mapFoldWithKey f noFacts body
- where f :: forall t a x. Label -> DBlock a t C x -> LabelMap a -> LabelMap a
- f lbl (DBlock f _) fb = mapInsert lbl f fb
-
---- implementation of the constructors (boring)
-
-dgnil = GNil
-dgnilC = GMany NothingO emptyBody NothingO
-
-dgSplice = splice fzCat
- where fzCat :: DBlock f n e O -> DBlock t n O x -> DBlock f n e x
- fzCat (DBlock f b1) (DBlock _ b2) = DBlock f $! b1 `blockAppend` b2
- -- NB. strictness, this function is hammered.
-
----------------------------------------------------------------
-- Utilities
----------------------------------------------------------------
--- Lifting based on shape:
--- - from nodes to blocks
--- - from facts to fact-like things
--- Lowering back:
--- - from fact-like things to facts
--- Note that the latter two functions depend only on the entry shape.
-class ShapeLifter e x where
- singletonDG :: f -> n e x -> DG f n e x
- fwdEntryFact :: NonLocal n => n e x -> f -> Fact e f
- fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label]
- ftransfer :: FwdTransfer n f -> n e x -> f -> Fact x f
- frewrite :: FwdRewrite m n f -> n e x
- -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))
--- @ end node.tex
- bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f
- btransfer :: BwdTransfer n f -> n e x -> Fact x f -> f
- brewrite :: BwdRewrite m n f -> n e x
- -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f))
-
-instance ShapeLifter C O where
- singletonDG f n = gUnitCO (DBlock f (BlockCO n BNil))
- fwdEntryFact n f = mapSingleton (entryLabel n) f
- bwdEntryFact lat n fb = getFact lat (entryLabel n) fb
- ftransfer (FwdTransfer3 (ft, _, _)) n f = ft n f
- btransfer (BwdTransfer3 (bt, _, _)) n f = bt n f
- frewrite (FwdRewrite3 (fr, _, _)) n f = fr n f
- brewrite (BwdRewrite3 (br, _, _)) n f = br n f
- fwdEntryLabel n = JustC [entryLabel n]
-
-instance ShapeLifter O O where
- singletonDG f = gUnitOO . DBlock f . BMiddle
- fwdEntryFact _ f = f
- bwdEntryFact _ _ f = f
- ftransfer (FwdTransfer3 (_, ft, _)) n f = ft n f
- btransfer (BwdTransfer3 (_, bt, _)) n f = bt n f
- frewrite (FwdRewrite3 (_, fr, _)) n f = fr n f
- brewrite (BwdRewrite3 (_, br, _)) n f = br n f
- fwdEntryLabel _ = NothingC
-
-instance ShapeLifter O C where
- singletonDG f n = gUnitOC (DBlock f (BlockOC BNil n))
- fwdEntryFact _ f = f
- bwdEntryFact _ _ f = f
- ftransfer (FwdTransfer3 (_, _, ft)) n f = ft n f
- btransfer (BwdTransfer3 (_, _, bt)) n f = bt n f
- frewrite (FwdRewrite3 (_, _, fr)) n f = fr n f
- brewrite (BwdRewrite3 (_, _, br)) n f = br n f
- fwdEntryLabel _ = NothingC
-
-{-
-class ShapeLifter e x where
- singletonDG :: f -> n e x -> DG f n e x
-
-instance ShapeLifter C O where
- singletonDG f n = gUnitCO (DBlock f (BlockCO n BNil))
-
-instance ShapeLifter O O where
- singletonDG f = gUnitOO . DBlock f . BMiddle
-
-instance ShapeLifter O C where
- singletonDG f n = gUnitOC (DBlock f (BlockOC BNil n))
--}
-
-- Fact lookup: the fact `orelse` bottom
getFact :: DataflowLattice f -> Label -> FactBase f -> f
getFact lat l fb = case lookupFact l fb of Just f -> f
Nothing -> fact_bot lat
-
-
-{- Note [Respects fuel]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--}
--- $fuel
--- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if
--- any function contained within the value satisfies the following properties:
---
--- * When fuel is exhausted, it always returns 'Nothing'.
---
--- * When it returns @Just g rw@, it consumes /exactly/ one unit
--- of fuel, and new rewrite 'rw' also respects fuel.
---
--- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3',
--- 'mkBRewrite', and 'mkBRewrite3' are not aware of the fuel supply,
--- the results respect fuel.
---
--- It is an /unchecked/ run-time error for the argument passed to 'wrapFR',
--- 'wrapFR2', 'wrapBR', or 'warpBR2' to return a function that does not respect fuel.
-
-- -----------------------------------------------------------------------------
-- a Heap of Int
View Lorry Controller Status