ghc-8.8.1: cmm/Hoopl/Dataflow.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
--
-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
-- and Norman Ramsey
--
-- Modifications copyright (c) The University of Glasgow 2012
--
-- This module is a specialised and optimised version of
-- Compiler.Hoopl.Dataflow in the hoopl package. In particular it is
-- specialised to the UniqSM monad.
--
module Hoopl.Dataflow
( C, O, Block
, lastNode, entryLabel
, foldNodesBwdOO
, foldRewriteNodesBwdOO
, DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)
, TransferFun, RewriteFun
, Fact, FactBase
, getFact, mkFactBase
, analyzeCmmFwd, analyzeCmmBwd
, rewriteCmmBwd
, changedIf
, joinOutFacts
, joinFacts
)
where
import GhcPrelude
import Cmm
import UniqSupply
import Data.Array
import Data.Maybe
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Hoopl.Block
import Hoopl.Graph
import Hoopl.Collections
import Hoopl.Label
type family Fact x f :: *
type instance Fact C f = FactBase f
type instance Fact O f = f
newtype OldFact a = OldFact a
newtype NewFact a = NewFact a
-- | The result of joining OldFact and NewFact.
data JoinedFact a
= Changed !a -- ^ Result is different than OldFact.
| NotChanged !a -- ^ Result is the same as OldFact.
getJoined :: JoinedFact a -> a
getJoined (Changed a) = a
getJoined (NotChanged a) = a
changedIf :: Bool -> a -> JoinedFact a
changedIf True = Changed
changedIf False = NotChanged
type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
data DataflowLattice a = DataflowLattice
{ fact_bot :: a
, fact_join :: JoinFun a
}
data Direction = Fwd | Bwd
type TransferFun f = CmmBlock -> FactBase f -> FactBase f
-- | Function for rewrtiting and analysis combined. To be used with
-- @rewriteCmm@.
--
-- Currently set to work with @UniqSM@ monad, but we could probably abstract
-- that away (if we do that, we might want to specialize the fixpoint algorithms
-- to the particular monads through SPECIALIZE).
type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)
analyzeCmmBwd, analyzeCmmFwd
:: DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmmBwd = analyzeCmm Bwd
analyzeCmmFwd = analyzeCmm Fwd
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
in fixpointAnalysis dir lattice transfer entry blockMap initFact
-- Fixpoint algorithm.
fixpointAnalysis
:: forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
fixpointAnalysis direction lattice do_block entry 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 entry blockmap
num_blocks = length blocks
block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
start = {-# SCC "start" #-} IntSet.fromDistinctAscList
[0 .. num_blocks - 1]
dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
join = fact_join lattice
loop
:: IntHeap -- ^ Worklist, i.e., blocks to process
-> FactBase f -- ^ Current result (increases monotonically)
-> FactBase f
loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =
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" #-}
mapFoldlWithKey
(updateFact join dep_blocks) (todo1, fbase1) out_facts
in loop todo2 fbase2
loop _ !fbase1 = fbase1
rewriteCmmBwd
:: DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmmBwd = rewriteCmm Bwd
rewriteCmm
:: Direction
-> DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmm dir lattice rwFun cmmGraph initFact = do
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap1 =
case hooplGraph of
GMany NothingO bm NothingO -> bm
(blockMap2, facts) <-
fixpointRewrite dir lattice rwFun entry blockMap1 initFact
return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)
fixpointRewrite
:: forall f.
Direction
-> DataflowLattice f
-> RewriteFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
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 dir entry blockmap
num_blocks = length blocks
block_arr = {-# SCC "block_arr_rewrite" #-}
listArray (0, num_blocks - 1) blocks
start = {-# SCC "start_rewrite" #-}
IntSet.fromDistinctAscList [0 .. num_blocks - 1]
dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks
join = fact_join lattice
loop
:: IntHeap -- ^ Worklist, i.e., blocks to process
-> LabelMap CmmBlock -- ^ Rewritten blocks.
-> FactBase f -- ^ Current facts.
-> UniqSM (LabelMap CmmBlock, FactBase f)
loop todo !blocks1 !fbase1
| Just (index, todo1) <- IntSet.minView todo = do
-- Note that we use the *original* block here. This is important.
-- We're optimistically rewriting blocks even before reaching the fixed
-- point, which means that the rewrite might be incorrect. So if the
-- facts change, we need to rewrite the original block again (taking
-- into account the new facts).
let block = block_arr ! index
(new_block, out_facts) <- {-# SCC "do_block_rewrite" #-}
do_block block fbase1
let blocks2 = mapInsert (entryLabel new_block) new_block blocks1
(todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
mapFoldlWithKey
(updateFact join dep_blocks) (todo1, fbase1) out_facts
loop todo2 blocks2 fbase2
loop _ !blocks1 !fbase1 = return (blocks1, fbase1)
{-
Note [Unreachable blocks]
~~~~~~~~~~~~~~~~~~~~~~~~~
A block that is not in the domain of tfb_fbase is "currently unreachable".
A currently-unreachable block is not even analyzed. Reason: consider
constant prop and this graph, with entry point L1:
L1: x:=3; goto L4
L2: x:=4; goto L4
L4: if x>3 goto L2 else goto L5
Here L2 is actually unreachable, but if we process it with bottom input fact,
we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
* If a currently-unreachable block is not analyzed, then its rewritten
graph will not be accumulated in tfb_rg. And that is good:
unreachable blocks simply do not appear in the output.
* Note that clients must be careful to provide a fact (even if bottom)
for each entry point. Otherwise useful blocks may be garbage collected.
* Note that updateFact must set the change-flag if a label goes from
not-in-fbase to in-fbase, even if its fact is bottom. In effect the
real fact lattice is
UNR
bottom
the points above bottom
* Even if the fact is going from UNR to bottom, we still call the
client's fact_join function because it might give the client
some useful debugging information.
* All of this only applies for *forward* ixpoints. For the backward
case we must treat every block as reachable; it might finish with a
'return', and therefore have no successors, for example.
-}
-----------------------------------------------------------------------------
-- Pieces that are shared by fixpoint and fixpoint_anal
-----------------------------------------------------------------------------
-- | Sort the blocks into the right order for analysis. This means reverse
-- postorder for a forward analysis. For the backward one, we simply reverse
-- that (see Note [Backward vs forward analysis]).
sortBlocks
:: NonLocal n
=> Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
sortBlocks direction entry blockmap =
case direction of
Fwd -> fwd
Bwd -> reverse fwd
where
fwd = revPostorderFrom blockmap entry
-- Note [Backward vs forward analysis]
--
-- The forward and backward cases are not dual. In the forward case, the entry
-- points are known, and one simply traverses the body blocks from those points.
-- In the backward case, something is known about the exit points, but a
-- backward analysis must also include reachable blocks that don't reach the
-- exit, as in a procedure that loops forever and has side effects.)
-- For instance, let E be the entry and X the exit blocks (arrows indicate
-- control flow)
-- E -> X
-- E -> B
-- B -> C
-- C -> B
-- We do need to include B and C even though they're unreachable in the
-- *reverse* graph (that we could use for backward analysis):
-- E <- X
-- E <- B
-- B <- C
-- C <- B
-- So when sorting the blocks for the backward analysis, we simply take the
-- reverse of what is used for the forward one.
-- | Construct a mapping from a @Label@ to the block indexes that should be
-- re-analyzed if the facts at that @Label@ change.
--
-- Note that we're considering here the entry point of the block, so if the
-- facts change at the entry:
-- * for a backward analysis we need to re-analyze all the predecessors, but
-- * for a forward analysis, we only need to re-analyze the current block
-- (and that will in turn propagate facts into its successors).
mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet
mkDepBlocks Fwd blocks = go blocks 0 mapEmpty
where
go [] !_ !dep_map = dep_map
go (b:bs) !n !dep_map =
go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map
mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
where
go [] !_ !dep_map = dep_map
go (b:bs) !n !dep_map =
let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m
in go bs (n + 1) $ foldl' insert dep_map (successors b)
-- | After some new facts have been generated by analysing a block, we
-- fold this function over them to generate (a) a list of block
-- indices to (re-)analyse, and (b) the new FactBase.
updateFact
:: JoinFun f
-> LabelMap IntSet
-> (IntHeap, FactBase f)
-> Label
-> f -- out fact
-> (IntHeap, FactBase f)
updateFact fact_join dep_blocks (todo, fbase) lbl new_fact
= case lookupFact lbl fbase of
Nothing ->
-- Note [No old fact]
let !z = mapInsert lbl new_fact fbase in (changed, z)
Just old_fact ->
case fact_join (OldFact old_fact) (NewFact new_fact) of
(NotChanged _) -> (todo, fbase)
(Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
where
changed = todo `IntSet.union`
mapFindWithDefault IntSet.empty lbl dep_blocks
{-
Note [No old fact]
We know that the new_fact is >= _|_, so we don't need to join. However,
if the new fact is also _|_, and we have already analysed its block,
we don't need to record a change. So there's a tradeoff here. It turns
out that always recording a change is faster.
-}
----------------------------------------------------------------
-- Utilities
----------------------------------------------------------------
-- 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
-- | Returns the result of joining the facts from all the successors of the
-- provided node or block.
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)
facts =
[ fromJust fact
| s <- successors nonLocal
, let fact = lookupFact s fact_base
, isJust fact
]
joinFacts :: DataflowLattice f -> [f] -> f
joinFacts lattice facts = foldl' join (fact_bot lattice) facts
where
join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
-- | Returns the joined facts for each label.
mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
mkFactBase lattice = foldl' add mapEmpty
where
join = fact_join lattice
add result (l, f1) =
let !newFact =
case mapLookup l result of
Nothing -> f1
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 #-}
-- | Folds backward over all the nodes of an open-open block and allows
-- rewriting them. The accumulator is both the block of nodes and @f@ (usually
-- dataflow facts).
-- Strict in both accumulated parts.
foldRewriteNodesBwdOO
:: forall f.
(CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))
-> Block CmmNode O O
-> f
-> UniqSM (Block CmmNode O O, f)
foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts
where
go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1
go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1
go (BMiddle node) !fact1 = rewriteOO node fact1
go BNil !fact = return (BNil, fact)
comp rew1 rew2 = \f1 -> do
(b, f2) <- rew2 f1
(a, !f3) <- rew1 f2
let !c = joinBlocksOO a b
return (c, f3)
{-# INLINE comp #-}
{-# INLINABLE foldRewriteNodesBwdOO #-}
joinBlocksOO :: Block n O O -> Block n O O -> Block n O O
joinBlocksOO BNil b = b
joinBlocksOO b BNil = b
joinBlocksOO (BMiddle n) b = blockCons n b
joinBlocksOO b (BMiddle n) = blockSnoc b n
joinBlocksOO b1 b2 = BCat b1 b2
type IntHeap = IntSet