Commit 9be5fadb authored by Simon Marlow's avatar Simon Marlow

snapshot of latest improvements

parent cd35b83b
......@@ -111,7 +111,7 @@ procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
-- what proc-points each block is reachable from
procPointAnalysis procPoints g =
-- pprTrace "procPointAnalysis" (ppr procPoints) $
dataflowAnalFwd g initProcPoints $ analFwd lattice forward
dataflowAnalFwdBlocks g initProcPoints $ analFwd lattice forward
where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
-- transfer equations
......
......@@ -66,7 +66,8 @@ module CmmUtils(
foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
analFwd, analBwd, analRewFwd, analRewBwd,
dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd
dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd,
dataflowAnalFwdBlocks
) where
#include "HsVersions.h"
......@@ -524,6 +525,15 @@ dataflowAnalFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
-- return facts
return (analyzeFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts))
dataflowAnalFwdBlocks :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> FwdPass FuelUniqSM n f
-> FuelUniqSM (BlockEnv f)
dataflowAnalFwdBlocks (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
-- (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
-- return facts
return (analyzeFwdBlocks fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts))
dataflowAnalBwd :: NonLocal n =>
GenCmmGraph n -> [(BlockId, f)]
-> BwdPass FuelUniqSM n f
......
......@@ -19,7 +19,7 @@ module Hoopl.Dataflow
, wrapBR, wrapBR2
, BwdRewrite, mkBRewrite, mkBRewrite3, getBRewrite3, noBwdRewrite
, analyzeAndRewriteFwd, analyzeAndRewriteBwd
, analyzeFwd, analyzeBwd
, analyzeFwd, analyzeFwdBlocks, analyzeBwd
)
where
......@@ -135,7 +135,7 @@ arfGraph :: forall n f e x . NonLocal n =>
Entries e -> Graph n e x -> Fact e f -> FuelUniqSM (DG f n e x, Fact x f)
arfGraph pass@FwdPass { fp_lattice = lattice,
fp_transfer = transfer,
fp_rewrite = rewrite } entries = graph
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)
......@@ -156,31 +156,31 @@ arfGraph pass@FwdPass { fp_lattice = lattice,
-> (f2 -> FuelUniqSM (DG f n a x, f3))
-> (f1 -> FuelUniqSM (DG f n e x, f3))
graph GNil = \f -> return (dgnil, f)
graph (GUnit blk) = block blk
graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x
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 -> FuelUniqSM (DG f n e C, Fact C f)
exit :: MaybeO x (Block n C O) -> Fact C f -> FuelUniqSM (DG f n C x, Fact x f)
exit (JustO blk) = arfx block blk
exit NothingO = \fb -> return (dgnilC, fb)
ebcat entry bdy = c entries entry
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 -> FuelUniqSM (DG f n e C, Fact C f)
c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy
c (JustC entries) NothingO = body entries bdy
c _ _ = error "bogus GADT pattern match failure"
c NothingC (JustO entry) f = (block entry `cat` body (successors entry) bdy) f
c (JustC entries) NothingO f = body entries bdy f
c _ _ _ = error "bogus GADT pattern match failure"
-- Lift from nodes to blocks
block BNil = \f -> return (dgnil, f)
block (BlockCO n b) = node n `cat` block b
block (BlockCC l b n) = node l `cat` block b `cat` node n
block (BlockOC b n) = block b `cat` node n
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) = node n
block (BCat b1 b2) = block b1 `cat` block b2
block (BHead h n) = block h `cat` node n
block (BTail n t) = node n `cat` block t
block (BMiddle n) f = node n f
block (BCat b1 b2) f = (block b1 `cat` block b2) f
block (BHead h n) f = (block h `cat` node n) f
block (BTail n t) f = (node n `cat` block t) f
{-# INLINE node #-}
node :: forall e x . (ShapeLifter e x)
......@@ -200,7 +200,8 @@ arfGraph pass@FwdPass { fp_lattice = lattice,
{-# INLINE cat #-}
cat ft1 ft2 f = do { (g1,f1) <- ft1 f
; (g2,f2) <- ft2 f1
; return (g1 `dgSplice` g2, f2) }
; let !g = g1 `dgSplice` g2
; return (g, f2) }
arfx :: forall x .
(Block n C x -> f -> FuelUniqSM (DG f n C x, Fact x f))
......@@ -268,19 +269,57 @@ analyzeFwd FwdPass { fp_lattice = lattice,
do_block b fb = block b entryFact
where entryFact = getFact lattice (entryLabel b) fb
-- NB. eta-expand block, GHC can't do this by itself. See #5809.
block :: forall e x . Block n e x -> f -> Fact x f
block BNil = id
block (BlockCO n b) = ftr n `cat` block b
block (BlockCC l b n) = ftr l `cat` block b `cat` ltr n
block (BlockOC b n) = block b `cat` ltr n
block BNil f = f
block (BlockCO n b) f = (ftr n `cat` block b) f
block (BlockCC l b n) f = (ftr l `cat` block b `cat` ltr n) f
block (BlockOC b n) f = (block b `cat` ltr n) f
block (BMiddle n) = mtr n
block (BCat b1 b2) = block b1 `cat` block b2
block (BHead h n) = block h `cat` mtr n
block (BTail n t) = mtr n `cat` block t
block (BMiddle n) f = {-# SCC "b1" #-} mtr n f
block (BCat b1 b2) f = {-# SCC "b2" #-} (block b1 `cat` block b2) f
block (BHead h n) f = {-# SCC "b3" #-} (block h `cat` mtr n) f
block (BTail n t) f = {-# SCC "b4" #-} (mtr n `cat` block t) f
{-# INLINE cat #-}
cat ft1 ft2 f = ft2 (ft1 f)
cat ft1 ft2 = \f -> ft2 $! ft1 f
-- | if the graph being analyzed is open at the entry, there must
-- be no other entry point, or all goes horribly wrong...
analyzeFwdBlocks
:: forall n f e . NonLocal n =>
FwdPass FuelUniqSM n f
-> MaybeC e [Label]
-> Graph n e C -> Fact e f
-> FactBase f
analyzeFwdBlocks FwdPass { fp_lattice = lattice,
fp_transfer = FwdTransfer3 (ftr, _, ltr) }
entries g in_fact = graph g in_fact
where
graph :: Graph n e C -> Fact e f -> FactBase f
graph (GMany entry blockmap NothingO)
= case (entries, entry) of
(NothingC, JustO entry) -> block entry `cat` body (successors entry)
(JustC entries, NothingO) -> body entries
_ -> error "bogus GADT pattern match failure"
where
body :: [Label] -> Fact C f -> Fact C f
body entries f
= fixpoint_anal Fwd lattice do_block entries blockmap f
where
do_block :: forall x . Block n C x -> FactBase f -> Fact x f
do_block b fb = block b entryFact
where entryFact = getFact lattice (entryLabel b) fb
-- NB. eta-expand block, GHC can't do this by itself. See #5809.
block :: forall e x . Block n e x -> f -> Fact x f
block BNil f = f
block (BlockCO n b) f = ftr n f
block (BlockCC l b n) f = (ftr l `cat` ltr n) f
block (BlockOC b n) f = ltr n f
{-# INLINE cat #-}
cat ft1 ft2 = \f -> ft2 $! ft1 f
----------------------------------------------------------------
-- Backward Analysis only
......@@ -312,19 +351,20 @@ analyzeBwd BwdPass { bp_lattice = lattice,
do_block :: forall x . Block n C x -> Fact x f -> FactBase f
do_block b fb = mapSingleton (entryLabel b) (block b fb)
-- NB. eta-expand block, GHC can't do this by itself. See #5809.
block :: forall e x . Block n e x -> Fact x f -> f
block BNil = id
block (BlockCO n b) = ftr n `cat` block b
block (BlockCC l b n) = ftr l `cat` block b `cat` ltr n
block (BlockOC b n) = block b `cat` ltr n
block BNil f = f
block (BlockCO n b) f = (ftr n `cat` block b) f
block (BlockCC l b n) f = (ftr l `cat` block b `cat` ltr n) f
block (BlockOC b n) f = (block b `cat` ltr n) f
block (BMiddle n) = mtr n
block (BCat b1 b2) = block b1 `cat` block b2
block (BHead h n) = block h `cat` mtr n
block (BTail n t) = mtr n `cat` block t
block (BMiddle n) f = mtr n f
block (BCat b1 b2) f = (block b1 `cat` block b2) f
block (BHead h n) f = (block h `cat` mtr n) f
block (BTail n t) f = (mtr n `cat` block t) f
{-# INLINE cat #-}
cat ft1 ft2 f = ft1 (ft2 f)
cat ft1 ft2 = \f -> ft1 $! ft2 f
-----------------------------------------------------------------------------
-- Backward analysis and rewriting: the interface
......@@ -362,7 +402,7 @@ arbGraph :: forall n f e x .
Entries e -> Graph n e x -> Fact x f -> FuelUniqSM (DG f n e x, Fact e f)
arbGraph pass@BwdPass { bp_lattice = lattice,
bp_transfer = transfer,
bp_rewrite = rewrite } entries = graph
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)
......@@ -378,30 +418,31 @@ arbGraph pass@BwdPass { bp_lattice = lattice,
-> (info -> FuelUniqSM (DG f n a x, info'))
-> (info -> FuelUniqSM (DG f n e x, info''))
graph GNil = \f -> return (dgnil, f)
graph (GUnit blk) = block blk
graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x
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 -> FuelUniqSM (DG f n e C, Fact e f)
exit :: MaybeO x (Block n C O) -> Fact x f -> FuelUniqSM (DG f n C x, Fact C f)
exit (JustO blk) = arbx block blk
exit NothingO = \fb -> return (dgnilC, fb)
ebcat entry bdy = c entries entry
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 -> FuelUniqSM (DG f n e C, Fact e f)
c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy
c (JustC entries) NothingO = body entries bdy
c _ _ = error "bogus GADT pattern match failure"
c NothingC (JustO entry) f = (block entry `cat` body (successors entry) bdy) f
c (JustC entries) NothingO f = body entries bdy f
c _ _ _ = error "bogus GADT pattern match failure"
-- Lift from nodes to blocks
block BNil = \f -> return (dgnil, f)
block (BlockCO l b) = node l `cat` block b
block (BlockCC l b n) = node l `cat` block b `cat` node n
block (BlockOC b n) = block b `cat` node n
block (BMiddle n) = node n
block (BCat b1 b2) = block b1 `cat` block b2
block (BHead h n) = block h `cat` node n
block (BTail n t) = node n `cat` block t
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 (BHead h n) f = (block h `cat` node n) f
block (BTail n t) f = (node n `cat` block t) f
{-# INLINE node #-}
node n f
......@@ -419,7 +460,8 @@ arbGraph pass@BwdPass { bp_lattice = lattice,
{-# INLINE cat #-}
cat ft1 ft2 f = do { (g2,f2) <- ft2 f
; (g1,f1) <- ft1 f2
; return (g1 `dgSplice` g2, f1) }
; let !g = g1 `dgSplice` g2
; return (g, f1) }
arbx :: forall x .
(Block n C x -> Fact x f -> FuelUniqSM (DG f n C x, f))
......@@ -505,10 +547,13 @@ fixpoint_anal direction DataflowLattice{ fact_bot = bot, fact_join = join }
do_block entries blockmap init_fbase
= loop start init_fbase setEmpty
where
is_bwd = case direction of Bwd -> True; Fwd -> False
blocks = forwardBlockList entries blockmap
ordered_blocks = case direction of
Fwd -> blocks
Bwd -> reverse blocks
ordered_blocks | is_bwd = reverse blocks
| otherwise = blocks
block_arr = listArray (0,length blocks - 1) ordered_blocks
start | Fwd <- direction
......@@ -525,8 +570,6 @@ fixpoint_anal direction DataflowLattice{ fact_bot = bot, fact_join = join }
Bwd -> successors b
]
is_bwd = case direction of Bwd -> True; Fwd -> False
loop
:: IntSet -- blocks still to analyse
-> FactBase f -- current factbase (increases monotonically)
......@@ -539,7 +582,7 @@ fixpoint_anal direction DataflowLattice{ fact_bot = bot, fact_join = join }
let blk = block_arr ! ix
lbl = entryLabel blk
in
-- trace ("analysing: " ++ show lbl) $
-- trace ("analysing: " ++ show (entryLabel blk)) $
let out_facts = do_block blk fbase
(changed, fbase') = mapFoldWithKey
......@@ -651,9 +694,8 @@ fixpoint direction DataflowLattice{ fact_bot = bot, fact_join = join }
| IS.null todo = return (fbase, newblocks)
| (ix,todo') <- IS.deleteFindMin todo = do
let blk = block_arr ! ix
lbl = entryLabel blk
-- trace ("analysing: " ++ show lbl) $ return ()
-- trace ("analysing: " ++ show (entryLabel blk)) $ return ()
(rg, out_facts) <- do_block blk fbase
let (changed, fbase') = mapFoldWithKey
(updateFact bot join is_bwd newblocks)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment