Skip to content

GitLab

Glasgow Haskell Compiler
Glasgow Haskell Compiler
Commit 9be5fadb authored by Simon Marlow's avatar Simon Marlow
Browse files
Options

snapshot of latest improvements

parent cd35b83b
Show whitespace changes
Inline Side-by-side
Showing with 121 additions and 69 deletions
compiler/cmm/CmmProcPoint.hs
View file @ 9be5fadb
......@@ -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
......
compiler/cmm/CmmUtils.hs
View file @ 9be5fadb
......@@ -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
......
compiler/cmm/Hoopl/Dataflow.hs
View file @ 9be5fadb
......@@ -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