Commit 679ccd1c authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

Hoopl/Dataflow: use block-oriented interface

This introduces the new interface for dataflow analysis, where transfer
functions operate on a whole basic block.

The main changes are:
- Hoopl.Dataflow: implement the new interface and remove the old code;
  expose a utility function to do a strict fold over the nodes of a
  basic block (for analyses that do want to look at all the nodes)
- Refactor all the analyses to use the new interface.

One of the nice effects is that we can remove the `analyzeFwdBlocks`
hack that ignored the middle nodes (that existed for analyses that
didn't need to go over all the nodes). Now this is no longer a special
case and fits well with the new interface.
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan:
validate, earlier version of the patch had assertions
comparing the results with the old implementation

Reviewers: erikd, austin, simonmar, hvr, goldfire, bgamari

Reviewed By: bgamari

Subscribers: goldfire, erikd, thomie

Differential Revision: https://phabricator.haskell.org/D2754
parent b92f8e38
......@@ -85,7 +85,6 @@ This is what flattenCAFSets is doing.
type CAFSet = Set CLabel
type CAFEnv = BlockEnv CAFSet
-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
cafLattice = DataflowLattice Set.empty add
where
......@@ -93,21 +92,27 @@ cafLattice = DataflowLattice Set.empty add
let !new' = old `Set.union` new
in changedIf (Set.size new' > Set.size old) new'
cafTransfers :: BwdTransfer CmmNode CAFSet
cafTransfers = mkBTransfer3 first middle last
where first _ live = live
middle m live = foldExpDeep addCaf m live
last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
addCaf e set = case e of
CmmLit (CmmLabel c) -> add c set
CmmLit (CmmLabelOff c _) -> add c set
CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
_ -> set
add l s = if hasCAF l then Set.insert (toClosureLbl l) s
else s
cafTransfers :: TransferFun CAFSet
cafTransfers (BlockCC eNode middle xNode) fBase =
let joined = cafsInNode xNode $! joinOutFacts cafLattice xNode fBase
!result = foldNodesBwdOO cafsInNode middle joined
in mapSingleton (entryLabel eNode) result
cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
cafsInNode node set = foldExpDeep addCaf node set
where
addCaf expr !set =
case expr of
CmmLit (CmmLabel c) -> add c set
CmmLit (CmmLabelOff c _) -> add c set
CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $! add c2 set
_ -> set
add l s | hasCAF l = Set.insert (toClosureLbl l) s
| otherwise = s
-- | An analysis to find live CAFs.
cafAnal :: CmmGraph -> CAFEnv
cafAnal g = dataflowAnalBwd g [] cafLattice cafTransfers
cafAnal cmmGraph = analyzeCmmBwd cafLattice cafTransfers cmmGraph mapEmpty
-----------------------------------------------------------------------
-- Building the SRTs
......
......@@ -16,7 +16,7 @@ import DynFlags
import BlockId
import Cmm
import PprCmmExpr ()
import Hoopl.Dataflow
import Hoopl
import Maybes
import Outputable
......@@ -39,7 +39,6 @@ liveLattice = DataflowLattice emptyRegSet add
let !join = plusRegSet old new
in changedIf (sizeRegSet join > sizeRegSet old) join
-- | A mapping from block labels to the variables live on entry
type BlockEntryLiveness r = BlockEnv (CmmLive r)
......@@ -49,14 +48,15 @@ type BlockEntryLiveness r = BlockEnv (CmmLive r)
cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness dflags graph =
check $ dataflowAnalBwd graph [] liveLattice (xferLive dflags)
where entry = g_entry graph
check facts = noLiveOnEntry entry
(expectJust "check" $ mapLookup entry facts) facts
check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
where
entry = g_entry graph
check facts =
noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg
cmmGlobalLiveness dflags graph =
dataflowAnalBwd graph [] liveLattice (xferLive dflags)
analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
-- | On entry to the procedure, there had better not be any LocalReg's live-in.
noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a
......@@ -64,32 +64,25 @@ noLiveOnEntry bid in_fact x =
if nullRegSet in_fact then x
else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
-- | The transfer equations use the traditional 'gen' and 'kill'
-- notations, which should be familiar from the Dragon Book.
gen :: UserOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r
{-# INLINE gen #-}
gen dflags a live = foldRegsUsed dflags extendRegSet live a
kill :: DefinerOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r
{-# INLINE kill #-}
kill dflags a live = foldRegsDefd dflags deleteFromRegSet live a
gen_kill :: (DefinerOfRegs r a, UserOfRegs r a)
=> DynFlags -> a -> CmmLive r -> CmmLive r
gen_kill
:: (DefinerOfRegs r n, UserOfRegs r n)
=> DynFlags -> n -> CmmLive r -> CmmLive r
gen_kill dflags node set =
let !afterKill = foldRegsDefd dflags deleteFromRegSet set node
in foldRegsUsed dflags extendRegSet afterKill node
{-# INLINE gen_kill #-}
gen_kill dflags a = gen dflags a . kill dflags a
-- | The transfer function
xferLive :: forall r . ( UserOfRegs r (CmmNode O O)
, DefinerOfRegs r (CmmNode O O)
, UserOfRegs r (CmmNode O C)
, DefinerOfRegs r (CmmNode O C))
=> DynFlags -> BwdTransfer CmmNode (CmmLive r)
{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive LocalReg) #-}
{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive GlobalReg) #-}
xferLive dflags = mkBTransfer3 fst mid lst
where fst _ f = f
mid :: CmmNode O O -> CmmLive r -> CmmLive r
mid n f = gen_kill dflags n f
lst :: CmmNode O C -> FactBase (CmmLive r) -> CmmLive r
lst n f = gen_kill dflags n $ joinOutFacts liveLattice n f
xferLive
:: forall r.
( UserOfRegs r (CmmNode O O)
, DefinerOfRegs r (CmmNode O O)
, UserOfRegs r (CmmNode O C)
, DefinerOfRegs r (CmmNode O C)
)
=> DynFlags -> TransferFun (CmmLive r)
xferLive dflags (BlockCC eNode middle xNode) fBase =
let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase
!result = foldNodesBwdOO (gen_kill dflags) middle joined
in mapSingleton (entryLabel eNode) result
{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}
{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}
{-# LANGUAGE GADTs, DisambiguateRecordFields #-}
{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
module CmmProcPoint
( ProcPointSet, Status(..)
......@@ -17,7 +17,7 @@ import Cmm
import PprCmm ()
import CmmUtils
import CmmInfo
import CmmLive (cmmGlobalLiveness)
import CmmLive
import CmmSwitch
import Data.List (sortBy)
import Maybes
......@@ -25,7 +25,6 @@ import Control.Monad
import Outputable
import Platform
import UniqSupply
import Hoopl
-- Compute a minimal set of proc points for a control-flow graph.
......@@ -129,42 +128,44 @@ instance Outputable Status where
--------------------------------------------------
-- Proc point analysis
procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status)
-- Once you know what the proc-points are, figure out
-- what proc-points each block is reachable from
-- See Note [Proc-point analysis]
procPointAnalysis procPoints g@(CmmGraph {g_graph = graph}) =
-- pprTrace "procPointAnalysis" (ppr procPoints) $
return $ dataflowAnalFwdBlocks g initProcPoints lattice forward
where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints,
id `setMember` labelsInGraph ]
-- See Note [Non-existing proc-points]
labelsInGraph = labelsDefined graph
-- transfer equations
forward :: FwdTransfer CmmNode Status
forward = mkFTransfer3 first middle last
where
first :: CmmNode C O -> Status -> Status
first (CmmEntry id _) ProcPoint = ReachedBy $ setSingleton id
first _ x = x
middle _ x = x
last :: CmmNode O C -> Status -> FactBase Status
last l x = mkFactBase lattice $ map (\id -> (id, x)) (successors l)
lattice :: DataflowLattice Status
lattice = DataflowLattice unreached add_to
where unreached = ReachedBy setEmpty
add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
add_to _ (NewFact ProcPoint) = Changed ProcPoint
-- because of previous case
add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
| setSize union > setSize p = Changed (ReachedBy union)
| otherwise = NotChanged (ReachedBy p)
where
union = setUnion p' p
procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status)
procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
return $
analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
where
initProcPoints =
mkFactBase
procPointLattice
[ (id, ProcPoint)
| id <- setElems procPoints
-- See Note [Non-existing proc-points]
, id `setMember` labelsInGraph
]
labelsInGraph = labelsDefined graph
procPointTransfer :: TransferFun Status
procPointTransfer block facts =
let label = entryLabel block
!fact = case getFact procPointLattice label facts of
ProcPoint -> ReachedBy $! setSingleton label
f -> f
result = map (\id -> (id, fact)) (successors block)
in mkFactBase procPointLattice result
procPointLattice :: DataflowLattice Status
procPointLattice = DataflowLattice unreached add_to
where
unreached = ReachedBy setEmpty
add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
| setSize union > setSize p = Changed (ReachedBy union)
| otherwise = NotChanged (ReachedBy p)
where
union = setUnion p' p
----------------------------------------------------------------------
......
......@@ -18,16 +18,13 @@
--
module Hoopl.Dataflow
( C, O, DataflowLattice(..), OldFact(..), NewFact(..), Fact, FactBase
, mkFactBase
, JoinedFact(..)
, FwdPass(..), FwdTransfer, mkFTransfer3
, BwdPass(..), BwdTransfer, mkBTransfer3
, dataflowAnalFwdBlocks, dataflowAnalBwd
, analyzeFwd, analyzeFwdBlocks, analyzeBwd
( C, O, Block
, lastNode, entryLabel
, foldNodesBwdOO
, DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..), TransferFun
, Fact, FactBase
, getFact, mkFactBase
, analyzeCmmFwd, analyzeCmmBwd
, changedIf
, joinOutFacts
)
......@@ -69,212 +66,73 @@ data DataflowLattice a = DataflowLattice
, fact_join :: JoinFun a
}
-- TODO(michalt): This wrapper will go away once we refactor the analyze*
-- methods.
dataflowAnalFwdBlocks
:: NonLocal n
=> GenCmmGraph n
-> [(BlockId, f)]
-> DataflowLattice f
-> FwdTransfer n f
-> BlockEnv f
dataflowAnalFwdBlocks
(CmmGraph {g_entry = entry, g_graph = graph}) facts lattice xfer =
analyzeFwdBlocks
lattice xfer (JustC [entry]) graph (mkFactBase lattice facts)
-- TODO(michalt): This wrapper will go away once we refactor the analyze*
-- methods.
dataflowAnalBwd
:: NonLocal n
=> GenCmmGraph n
-> [(BlockId, f)]
-> DataflowLattice f
-> BwdTransfer n f
-> BlockEnv f
dataflowAnalBwd
(CmmGraph {g_entry = entry, g_graph = graph}) facts lattice xfer =
analyzeBwd lattice xfer (JustC [entry]) graph (mkFactBase lattice facts)
----------------------------------------------------------------
-- Forward Analysis only
----------------------------------------------------------------
-- | if the graph being analyzed is open at the entry, there must
-- be no other entry point, or all goes horribly wrong...
analyzeFwd
:: forall n f e . NonLocal n
=> DataflowLattice f
-> FwdTransfer n f
-> MaybeC e [Label]
-> Graph n e C -> Fact e f
-> FactBase f
analyzeFwd lattice (FwdTransfer3 (ftr, mtr, 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
where
body :: [Label] -> Fact C f -> Fact C f
body entries f
= fixpointAnal 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 `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) f = mtr n f
block (BCat b1 b2) f = (block b1 `cat` block b2) f
block (BSnoc h n) f = (block h `cat` mtr n) f
block (BCons n t) f = (mtr n `cat` block t) f
{-# INLINE cat #-}
cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
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
=> DataflowLattice f
-> FwdTransfer n f
-> MaybeC e [Label]
-> Graph n e C -> Fact e f
-> FactBase f
analyzeFwdBlocks lattice (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
where
body :: [Label] -> Fact C f -> Fact C f
body entries f
= fixpointAnal 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 _) f = ftr n f
block (BlockCC l _ n) f = (ftr l `cat` ltr n) f
block (BlockOC _ n) f = ltr n f
block _ _ = error "analyzeFwdBlocks"
{-# INLINE cat #-}
cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
cat ft1 ft2 = \f -> ft2 $! ft1 f
----------------------------------------------------------------
-- Backward Analysis only
----------------------------------------------------------------
-- | if the graph being analyzed is open at the entry, there must
-- be no other entry point, or all goes horribly wrong...
analyzeBwd
:: forall n f e . NonLocal n
=> DataflowLattice f
-> BwdTransfer n f
-> MaybeC e [Label]
-> Graph n e C -> Fact C f
-> FactBase f
analyzeBwd lattice (BwdTransfer3 (ftr, mtr, ltr)) entries g in_fact =
graph g in_fact
where
graph :: Graph n e C -> Fact C f -> FactBase f
graph (GMany entry blockmap NothingO)
= case (entries, entry) of
(NothingC, JustO entry) -> body (successors entry)
(JustC entries, NothingO) -> body entries
where
body :: [Label] -> Fact C f -> Fact C f
body entries f
= fixpointAnal Bwd lattice do_block entries blockmap f
where
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 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) f = mtr n f
block (BCat b1 b2) f = (block b1 `cat` block b2) f
block (BSnoc h n) f = (block h `cat` mtr n) f
block (BCons n t) f = (mtr n `cat` block t) f
{-# INLINE cat #-}
cat :: forall f1 f2 f3 . (f2 -> f3) -> (f1 -> f2) -> (f1 -> f3)
cat ft1 ft2 = \f -> ft1 $! ft2 f
data Direction = Fwd | Bwd
-----------------------------------------------------------------------------
-- fixpoint
-----------------------------------------------------------------------------
type TransferFun f = CmmBlock -> FactBase f -> FactBase f
data Direction = Fwd | Bwd
analyzeCmmBwd, analyzeCmmFwd
:: DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmmBwd = analyzeCmm Bwd
analyzeCmmFwd = analyzeCmm Fwd
-- | fixpointing for analysis-only
--
fixpointAnal :: forall n f. NonLocal n
=> Direction
-> DataflowLattice f
-> (Block n C C -> Fact C f -> Fact C f)
-> [Label]
-> LabelMap (Block n C C)
-> Fact C f -> FactBase f
fixpointAnal direction DataflowLattice{ fact_bot = _, fact_join = join }
do_block entries blockmap init_fbase
= loop start init_fbase
analyzeCmm
:: Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmm dir lattice transfer cmmGraph initFact =
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap =
case hooplGraph of
GMany NothingO bm NothingO -> bm
entries = if mapNull initFact then [entry] else mapKeys initFact
in fixpointAnalysis dir lattice transfer entries blockMap initFact
-- Fixpoint algorithm.
fixpointAnalysis
:: forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> [Label]
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
fixpointAnalysis direction lattice do_block entries blockmap = loop start
where
-- Sorting the blocks helps to minimize the number of times we need to
-- process blocks. For instance, for forward analysis we want to look at
-- blocks in reverse postorder. Also, see comments for sortBlocks.
blocks = sortBlocks direction entries blockmap
n = length blocks
block_arr = {-# SCC "block_arr" #-} listArray (0,n-1) blocks
start = {-# SCC "start" #-} [0..n-1]
num_blocks = length blocks
block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
start = {-# SCC "start" #-} [0 .. num_blocks - 1]
dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
join = fact_join lattice
loop
:: IntHeap -- blocks still to analyse
-> FactBase f -- current factbase (increases monotonically)
-> FactBase f
loop [] fbase = fbase
loop (ix:todo) fbase =
let
blk = block_arr ! ix
:: IntHeap -- ^ Worklist, i.e., blocks to process
-> FactBase f -- ^ Current result (increases monotonically)
-> FactBase f
loop [] !fbase1 = fbase1
loop (index : todo1) !fbase1 =
let block = block_arr ! index
out_facts = {-# SCC "do_block" #-} do_block block fbase1
-- For each of the outgoing edges, we join it with the current
-- information in fbase1 and (if something changed) we update it
-- and add the affected blocks to the worklist.
(todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
mapFoldWithKey
(updateFact join dep_blocks) (todo1, fbase1) out_facts
in loop todo2 fbase2
out_facts = {-# SCC "do_block" #-} do_block blk fbase
!(todo', fbase') = {-# SCC "mapFoldWithKey" #-}
mapFoldWithKey (updateFact join dep_blocks)
(todo,fbase) out_facts
in
-- trace ("analysing: " ++ show (entryLabel blk)) $
-- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()
-- trace ("changed: " ++ show changed) $ return ()
-- trace ("to analyse: " ++ show to_analyse) $ return ()
loop todo' fbase'
{-
......@@ -412,7 +270,7 @@ getFact lat l fb = case lookupFact l fb of Just f -> f
-- | Returns the result of joining the facts from all the successors of the
-- provided node or block.
joinOutFacts :: (NonLocal n) => DataflowLattice f -> n O C -> FactBase f -> f
joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
where
join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
......@@ -436,6 +294,17 @@ mkFactBase lattice = foldl' add mapEmpty
Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
in mapInsert l newFact result
-- | Folds backward over all nodes of an open-open block.
-- Strict in the accumulator.
foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO funOO = go
where
go (BCat b1 b2) f = go b1 $! go b2 f
go (BSnoc h n) f = go h $! funOO n f
go (BCons n t) f = funOO n $! go t f
go (BMiddle n) f = funOO n f
go BNil f = f
{-# INLINABLE foldNodesBwdOO #-}
-- -----------------------------------------------------------------------------
-- a Heap of Int
......
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