Skip to content
Permalink
Browse files

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 <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
  • Loading branch information...
michalt authored and bgamari committed Nov 29, 2016
1 parent b92f8e3 commit 679ccd1c8860f1ef4b589c9593b74d04c97ae836
Showing with 160 additions and 292 deletions.
  1. +19 −14 compiler/cmm/CmmBuildInfoTables.hs
  2. +27 −34 compiler/cmm/CmmLive.hs
  3. +37 −36 compiler/cmm/CmmProcPoint.hs
  4. +77 −208 compiler/cmm/Hoopl/Dataflow.hs
@@ -85,29 +85,34 @@ 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
add (OldFact old) (NewFact new) =
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,47 +48,41 @@ 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
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) #-}
@@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, DisambiguateRecordFields #-}
{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}

module CmmProcPoint
( ProcPointSet, Status(..)
@@ -17,15 +17,14 @@ import Cmm
import PprCmm ()
import CmmUtils
import CmmInfo
import CmmLive (cmmGlobalLiveness)
import CmmLive
import CmmSwitch
import Data.List (sortBy)
import Maybes
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

----------------------------------------------------------------------

0 comments on commit 679ccd1

Please sign in to comment.
You can’t perform that action at this time.