{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
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 :: Extensibility) f :: *
type instance Fact C f = FactBase f
type instance Fact O f = f
newtype OldFact a = OldFact a
newtype NewFact a = NewFact a
data JoinedFact a
= Changed !a
| NotChanged !a
getJoined :: JoinedFact a -> a
getJoined :: JoinedFact a -> a
getJoined (Changed a
a) = a
a
getJoined (NotChanged a
a) = a
a
changedIf :: Bool -> a -> JoinedFact a
changedIf :: Bool -> a -> JoinedFact a
changedIf Bool
True = a -> JoinedFact a
forall a. a -> JoinedFact a
Changed
changedIf Bool
False = a -> JoinedFact a
forall a. a -> JoinedFact a
NotChanged
type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
data DataflowLattice a = DataflowLattice
{ DataflowLattice a -> a
fact_bot :: a
, DataflowLattice a -> JoinFun a
fact_join :: JoinFun a
}
data Direction = Fwd | Bwd
type TransferFun f = CmmBlock -> FactBase f -> FactBase f
type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)
analyzeCmmBwd, analyzeCmmFwd
:: DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmmBwd :: DataflowLattice f
-> TransferFun f -> CmmGraph -> FactBase f -> FactBase f
analyzeCmmBwd = Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmm Direction
Bwd
analyzeCmmFwd :: DataflowLattice f
-> TransferFun f -> CmmGraph -> FactBase f -> FactBase f
analyzeCmmFwd = Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmm Direction
Fwd
analyzeCmm
:: Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmm :: Direction
-> DataflowLattice f
-> TransferFun f
-> CmmGraph
-> FactBase f
-> FactBase f
analyzeCmm Direction
dir DataflowLattice f
lattice TransferFun f
transfer CmmGraph
cmmGraph FactBase f
initFact =
{-# SCC analyzeCmm #-}
let entry :: BlockId
entry = CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
cmmGraph
hooplGraph :: Graph CmmNode C C
hooplGraph = CmmGraph -> Graph CmmNode C C
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Graph n C C
g_graph CmmGraph
cmmGraph
blockMap :: LabelMap CmmBlock
blockMap =
case Graph CmmNode C C
hooplGraph of
GMany MaybeO C (Block CmmNode O C)
NothingO LabelMap CmmBlock
bm MaybeO C (Block CmmNode C O)
NothingO -> LabelMap CmmBlock
bm
in Direction
-> DataflowLattice f
-> TransferFun f
-> BlockId
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> BlockId
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
fixpointAnalysis Direction
dir DataflowLattice f
lattice TransferFun f
transfer BlockId
entry LabelMap CmmBlock
blockMap FactBase f
initFact
fixpointAnalysis
:: forall f.
Direction
-> DataflowLattice f
-> TransferFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
fixpointAnalysis :: Direction
-> DataflowLattice f
-> TransferFun f
-> BlockId
-> LabelMap CmmBlock
-> FactBase f
-> FactBase f
fixpointAnalysis Direction
direction DataflowLattice f
lattice TransferFun f
do_block BlockId
entry LabelMap CmmBlock
blockmap = IntHeap -> FactBase f -> FactBase f
loop IntHeap
start
where
blocks :: [CmmBlock]
blocks = Direction -> BlockId -> LabelMap CmmBlock -> [CmmBlock]
forall (n :: Extensibility -> Extensibility -> *).
NonLocal n =>
Direction -> BlockId -> LabelMap (Block n C C) -> [Block n C C]
sortBlocks Direction
direction BlockId
entry LabelMap CmmBlock
blockmap
num_blocks :: Int
num_blocks = [CmmBlock] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmBlock]
blocks
block_arr :: Array Int CmmBlock
block_arr = {-# SCC "block_arr" #-} (Int, Int) -> [CmmBlock] -> Array Int CmmBlock
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
num_blocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [CmmBlock]
blocks
start :: IntHeap
start = {-# SCC "start" #-} [Int] -> IntHeap
IntSet.fromDistinctAscList
[Int
0 .. Int
num_blocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
dep_blocks :: LabelMap IntHeap
dep_blocks = {-# SCC "dep_blocks" #-} Direction -> [CmmBlock] -> LabelMap IntHeap
mkDepBlocks Direction
direction [CmmBlock]
blocks
join :: JoinFun f
join = DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice
loop
:: IntHeap
-> FactBase f
-> FactBase f
loop :: IntHeap -> FactBase f -> FactBase f
loop IntHeap
todo !FactBase f
fbase1 | Just (Int
index, IntHeap
todo1) <- IntHeap -> Maybe (Int, IntHeap)
IntSet.minView IntHeap
todo =
let block :: CmmBlock
block = Array Int CmmBlock
block_arr Array Int CmmBlock -> Int -> CmmBlock
forall i e. Ix i => Array i e -> i -> e
! Int
index
out_facts :: FactBase f
out_facts = {-# SCC "do_block" #-} TransferFun f
do_block CmmBlock
block FactBase f
fbase1
(IntHeap
todo2, FactBase f
fbase2) = {-# SCC "mapFoldWithKey" #-}
((IntHeap, FactBase f)
-> KeyOf LabelMap -> f -> (IntHeap, FactBase f))
-> (IntHeap, FactBase f) -> FactBase f -> (IntHeap, FactBase f)
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey
(JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> BlockId
-> f
-> (IntHeap, FactBase f)
forall f.
JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> BlockId
-> f
-> (IntHeap, FactBase f)
updateFact JoinFun f
join LabelMap IntHeap
dep_blocks) (IntHeap
todo1, FactBase f
fbase1) FactBase f
out_facts
in IntHeap -> FactBase f -> FactBase f
loop IntHeap
todo2 FactBase f
fbase2
loop IntHeap
_ !FactBase f
fbase1 = FactBase f
fbase1
rewriteCmmBwd
:: DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmmBwd :: DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmmBwd = Direction
-> DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
forall f.
Direction
-> DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmm Direction
Bwd
rewriteCmm
:: Direction
-> DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmm :: Direction
-> DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmm Direction
dir DataflowLattice f
lattice RewriteFun f
rwFun CmmGraph
cmmGraph FactBase f
initFact = {-# SCC rewriteCmm #-} do
let entry :: BlockId
entry = CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
cmmGraph
hooplGraph :: Graph CmmNode C C
hooplGraph = CmmGraph -> Graph CmmNode C C
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Graph n C C
g_graph CmmGraph
cmmGraph
blockMap1 :: LabelMap CmmBlock
blockMap1 =
case Graph CmmNode C C
hooplGraph of
GMany MaybeO C (Block CmmNode O C)
NothingO LabelMap CmmBlock
bm MaybeO C (Block CmmNode C O)
NothingO -> LabelMap CmmBlock
bm
(LabelMap CmmBlock
blockMap2, FactBase f
facts) <-
Direction
-> DataflowLattice f
-> RewriteFun f
-> BlockId
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
forall f.
Direction
-> DataflowLattice f
-> RewriteFun f
-> BlockId
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
fixpointRewrite Direction
dir DataflowLattice f
lattice RewriteFun f
rwFun BlockId
entry LabelMap CmmBlock
blockMap1 FactBase f
initFact
(CmmGraph, FactBase f) -> UniqSM (CmmGraph, FactBase f)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGraph
cmmGraph {g_graph :: Graph CmmNode C C
g_graph = MaybeO C (Block CmmNode O C)
-> LabelMap CmmBlock
-> MaybeO C (Block CmmNode C O)
-> Graph CmmNode C C
forall (e :: Extensibility)
(block :: (Extensibility -> Extensibility -> *)
-> Extensibility -> Extensibility -> *)
(n :: Extensibility -> Extensibility -> *) (x :: Extensibility).
MaybeO e (block n O C)
-> Body' block n -> MaybeO x (block n C O) -> Graph' block n e x
GMany MaybeO C (Block CmmNode O C)
forall t. MaybeO C t
NothingO LabelMap CmmBlock
blockMap2 MaybeO C (Block CmmNode C O)
forall t. MaybeO C t
NothingO}, FactBase f
facts)
fixpointRewrite
:: forall f.
Direction
-> DataflowLattice f
-> RewriteFun f
-> Label
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
fixpointRewrite :: Direction
-> DataflowLattice f
-> RewriteFun f
-> BlockId
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
fixpointRewrite Direction
dir DataflowLattice f
lattice RewriteFun f
do_block BlockId
entry LabelMap CmmBlock
blockmap = IntHeap
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
loop IntHeap
start LabelMap CmmBlock
blockmap
where
blocks :: [CmmBlock]
blocks = Direction -> BlockId -> LabelMap CmmBlock -> [CmmBlock]
forall (n :: Extensibility -> Extensibility -> *).
NonLocal n =>
Direction -> BlockId -> LabelMap (Block n C C) -> [Block n C C]
sortBlocks Direction
dir BlockId
entry LabelMap CmmBlock
blockmap
num_blocks :: Int
num_blocks = [CmmBlock] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmBlock]
blocks
block_arr :: Array Int CmmBlock
block_arr = {-# SCC "block_arr_rewrite" #-}
(Int, Int) -> [CmmBlock] -> Array Int CmmBlock
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
num_blocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [CmmBlock]
blocks
start :: IntHeap
start = {-# SCC "start_rewrite" #-}
[Int] -> IntHeap
IntSet.fromDistinctAscList [Int
0 .. Int
num_blocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
dep_blocks :: LabelMap IntHeap
dep_blocks = {-# SCC "dep_blocks_rewrite" #-} Direction -> [CmmBlock] -> LabelMap IntHeap
mkDepBlocks Direction
dir [CmmBlock]
blocks
join :: JoinFun f
join = DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice
loop
:: IntHeap
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
loop :: IntHeap
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
loop IntHeap
todo !LabelMap CmmBlock
blocks1 !FactBase f
fbase1
| Just (Int
index, IntHeap
todo1) <- IntHeap -> Maybe (Int, IntHeap)
IntSet.minView IntHeap
todo = do
let block :: CmmBlock
block = Array Int CmmBlock
block_arr Array Int CmmBlock -> Int -> CmmBlock
forall i e. Ix i => Array i e -> i -> e
! Int
index
(CmmBlock
new_block, FactBase f
out_facts) <- {-# SCC "do_block_rewrite" #-}
RewriteFun f
do_block CmmBlock
block FactBase f
fbase1
let blocks2 :: LabelMap CmmBlock
blocks2 = KeyOf LabelMap
-> CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
new_block) CmmBlock
new_block LabelMap CmmBlock
blocks1
(IntHeap
todo2, FactBase f
fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
((IntHeap, FactBase f)
-> KeyOf LabelMap -> f -> (IntHeap, FactBase f))
-> (IntHeap, FactBase f) -> FactBase f -> (IntHeap, FactBase f)
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey
(JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> BlockId
-> f
-> (IntHeap, FactBase f)
forall f.
JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> BlockId
-> f
-> (IntHeap, FactBase f)
updateFact JoinFun f
join LabelMap IntHeap
dep_blocks) (IntHeap
todo1, FactBase f
fbase1) FactBase f
out_facts
IntHeap
-> LabelMap CmmBlock
-> FactBase f
-> UniqSM (LabelMap CmmBlock, FactBase f)
loop IntHeap
todo2 LabelMap CmmBlock
blocks2 FactBase f
fbase2
loop IntHeap
_ !LabelMap CmmBlock
blocks1 !FactBase f
fbase1 = (LabelMap CmmBlock, FactBase f)
-> UniqSM (LabelMap CmmBlock, FactBase f)
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap CmmBlock
blocks1, FactBase f
fbase1)
sortBlocks
:: NonLocal n
=> Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
sortBlocks :: Direction -> BlockId -> LabelMap (Block n C C) -> [Block n C C]
sortBlocks Direction
direction BlockId
entry LabelMap (Block n C C)
blockmap =
case Direction
direction of
Direction
Fwd -> [Block n C C]
fwd
Direction
Bwd -> [Block n C C] -> [Block n C C]
forall a. [a] -> [a]
reverse [Block n C C]
fwd
where
fwd :: [Block n C C]
fwd = LabelMap (Block n C C) -> BlockId -> [Block n C C]
forall (block :: Extensibility -> Extensibility -> *).
NonLocal block =>
LabelMap (block C C) -> BlockId -> [block C C]
revPostorderFrom LabelMap (Block n C C)
blockmap BlockId
entry
mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet
mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntHeap
mkDepBlocks Direction
Fwd [CmmBlock]
blocks = [CmmBlock] -> Int -> LabelMap IntHeap -> LabelMap IntHeap
forall (map :: * -> *)
(thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
(IsMap map, NonLocal thing, KeyOf map ~ BlockId) =>
[thing C x] -> Int -> map IntHeap -> map IntHeap
go [CmmBlock]
blocks Int
0 LabelMap IntHeap
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
where
go :: [thing C x] -> Int -> map IntHeap -> map IntHeap
go [] !Int
_ !map IntHeap
dep_map = map IntHeap
dep_map
go (thing C x
b:[thing C x]
bs) !Int
n !map IntHeap
dep_map =
[thing C x] -> Int -> map IntHeap -> map IntHeap
go [thing C x]
bs (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (map IntHeap -> map IntHeap) -> map IntHeap -> map IntHeap
forall a b. (a -> b) -> a -> b
$ KeyOf map -> IntHeap -> map IntHeap -> map IntHeap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (thing C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel thing C x
b) (Int -> IntHeap
IntSet.singleton Int
n) map IntHeap
dep_map
mkDepBlocks Direction
Bwd [CmmBlock]
blocks = [CmmBlock] -> Int -> LabelMap IntHeap -> LabelMap IntHeap
forall (map :: * -> *)
(thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
(IsMap map, NonLocal thing, KeyOf map ~ BlockId) =>
[thing e C] -> Int -> map IntHeap -> map IntHeap
go [CmmBlock]
blocks Int
0 LabelMap IntHeap
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
where
go :: [thing e C] -> Int -> map IntHeap -> map IntHeap
go [] !Int
_ !map IntHeap
dep_map = map IntHeap
dep_map
go (thing e C
b:[thing e C]
bs) !Int
n !map IntHeap
dep_map =
let insert :: map IntHeap -> BlockId -> map IntHeap
insert map IntHeap
m BlockId
l = (IntHeap -> IntHeap -> IntHeap)
-> KeyOf map -> IntHeap -> map IntHeap -> map IntHeap
forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith IntHeap -> IntHeap -> IntHeap
IntSet.union KeyOf map
BlockId
l (Int -> IntHeap
IntSet.singleton Int
n) map IntHeap
m
in [thing e C] -> Int -> map IntHeap -> map IntHeap
go [thing e C]
bs (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (map IntHeap -> map IntHeap) -> map IntHeap -> map IntHeap
forall a b. (a -> b) -> a -> b
$ (map IntHeap -> BlockId -> map IntHeap)
-> map IntHeap -> [BlockId] -> map IntHeap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' map IntHeap -> BlockId -> map IntHeap
insert map IntHeap
dep_map (thing e C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors thing e C
b)
updateFact
:: JoinFun f
-> LabelMap IntSet
-> (IntHeap, FactBase f)
-> Label
-> f
-> (IntHeap, FactBase f)
updateFact :: JoinFun f
-> LabelMap IntHeap
-> (IntHeap, FactBase f)
-> BlockId
-> f
-> (IntHeap, FactBase f)
updateFact JoinFun f
fact_join LabelMap IntHeap
dep_blocks (IntHeap
todo, FactBase f
fbase) BlockId
lbl f
new_fact
= case BlockId -> FactBase f -> Maybe f
forall f. BlockId -> FactBase f -> Maybe f
lookupFact BlockId
lbl FactBase f
fbase of
Maybe f
Nothing ->
let !z :: FactBase f
z = KeyOf LabelMap -> f -> FactBase f -> FactBase f
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
lbl f
new_fact FactBase f
fbase in (IntHeap
changed, FactBase f
z)
Just f
old_fact ->
case JoinFun f
fact_join (f -> OldFact f
forall a. a -> OldFact a
OldFact f
old_fact) (f -> NewFact f
forall a. a -> NewFact a
NewFact f
new_fact) of
(NotChanged f
_) -> (IntHeap
todo, FactBase f
fbase)
(Changed f
f) -> let !z :: FactBase f
z = KeyOf LabelMap -> f -> FactBase f -> FactBase f
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
lbl f
f FactBase f
fbase in (IntHeap
changed, FactBase f
z)
where
changed :: IntHeap
changed = IntHeap
todo IntHeap -> IntHeap -> IntHeap
`IntSet.union`
IntHeap -> KeyOf LabelMap -> LabelMap IntHeap -> IntHeap
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault IntHeap
IntSet.empty KeyOf LabelMap
BlockId
lbl LabelMap IntHeap
dep_blocks
getFact :: DataflowLattice f -> Label -> FactBase f -> f
getFact :: DataflowLattice f -> BlockId -> FactBase f -> f
getFact DataflowLattice f
lat BlockId
l FactBase f
fb = case BlockId -> FactBase f -> Maybe f
forall f. BlockId -> FactBase f -> Maybe f
lookupFact BlockId
l FactBase f
fb of Just f
f -> f
f
Maybe f
Nothing -> DataflowLattice f -> f
forall a. DataflowLattice a -> a
fact_bot DataflowLattice f
lat
joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts :: DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts DataflowLattice f
lattice n e C
nonLocal FactBase f
fact_base = (f -> f -> f) -> f -> [f] -> f
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' f -> f -> f
join (DataflowLattice f -> f
forall a. DataflowLattice a -> a
fact_bot DataflowLattice f
lattice) [f]
facts
where
join :: f -> f -> f
join f
new f
old = JoinedFact f -> f
forall a. JoinedFact a -> a
getJoined (JoinedFact f -> f) -> JoinedFact f -> f
forall a b. (a -> b) -> a -> b
$ DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice (f -> OldFact f
forall a. a -> OldFact a
OldFact f
old) (f -> NewFact f
forall a. a -> NewFact a
NewFact f
new)
facts :: [f]
facts =
[ Maybe f -> f
forall a. HasCallStack => Maybe a -> a
fromJust Maybe f
fact
| BlockId
s <- n e C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors n e C
nonLocal
, let fact :: Maybe f
fact = BlockId -> FactBase f -> Maybe f
forall f. BlockId -> FactBase f -> Maybe f
lookupFact BlockId
s FactBase f
fact_base
, Maybe f -> Bool
forall a. Maybe a -> Bool
isJust Maybe f
fact
]
joinFacts :: DataflowLattice f -> [f] -> f
joinFacts :: DataflowLattice f -> [f] -> f
joinFacts DataflowLattice f
lattice [f]
facts = (f -> f -> f) -> f -> [f] -> f
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' f -> f -> f
join (DataflowLattice f -> f
forall a. DataflowLattice a -> a
fact_bot DataflowLattice f
lattice) [f]
facts
where
join :: f -> f -> f
join f
new f
old = JoinedFact f -> f
forall a. JoinedFact a -> a
getJoined (JoinedFact f -> f) -> JoinedFact f -> f
forall a b. (a -> b) -> a -> b
$ DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice (f -> OldFact f
forall a. a -> OldFact a
OldFact f
old) (f -> NewFact f
forall a. a -> NewFact a
NewFact f
new)
mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
mkFactBase :: DataflowLattice f -> [(BlockId, f)] -> FactBase f
mkFactBase DataflowLattice f
lattice = (FactBase f -> (BlockId, f) -> FactBase f)
-> FactBase f -> [(BlockId, f)] -> FactBase f
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' FactBase f -> (BlockId, f) -> FactBase f
add FactBase f
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
where
join :: JoinFun f
join = DataflowLattice f -> JoinFun f
forall a. DataflowLattice a -> JoinFun a
fact_join DataflowLattice f
lattice
add :: FactBase f -> (BlockId, f) -> FactBase f
add FactBase f
result (BlockId
l, f
f1) =
let !newFact :: f
newFact =
case KeyOf LabelMap -> FactBase f -> Maybe f
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l FactBase f
result of
Maybe f
Nothing -> f
f1
Just f
f2 -> JoinedFact f -> f
forall a. JoinedFact a -> a
getJoined (JoinedFact f -> f) -> JoinedFact f -> f
forall a b. (a -> b) -> a -> b
$ JoinFun f
join (f -> OldFact f
forall a. a -> OldFact a
OldFact f
f1) (f -> NewFact f
forall a. a -> NewFact a
NewFact f
f2)
in KeyOf LabelMap -> f -> FactBase f -> FactBase f
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
l f
newFact FactBase f
result
foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO CmmNode O O -> f -> f
funOO = Block CmmNode O O -> f -> f
go
where
go :: Block CmmNode O O -> f -> f
go (BCat Block CmmNode O O
b1 Block CmmNode O O
b2) f
f = Block CmmNode O O -> f -> f
go Block CmmNode O O
b1 (f -> f) -> f -> f
forall a b. (a -> b) -> a -> b
$! Block CmmNode O O -> f -> f
go Block CmmNode O O
b2 f
f
go (BSnoc Block CmmNode O O
h CmmNode O O
n) f
f = Block CmmNode O O -> f -> f
go Block CmmNode O O
h (f -> f) -> f -> f
forall a b. (a -> b) -> a -> b
$! CmmNode O O -> f -> f
funOO CmmNode O O
n f
f
go (BCons CmmNode O O
n Block CmmNode O O
t) f
f = CmmNode O O -> f -> f
funOO CmmNode O O
n (f -> f) -> f -> f
forall a b. (a -> b) -> a -> b
$! Block CmmNode O O -> f -> f
go Block CmmNode O O
t f
f
go (BMiddle CmmNode O O
n) f
f = CmmNode O O -> f -> f
funOO CmmNode O O
n f
f
go Block CmmNode O O
BNil f
f = f
f
{-# INLINABLE foldNodesBwdOO #-}
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 :: (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))
-> Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
foldRewriteNodesBwdOO CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
rewriteOO Block CmmNode O O
initBlock f
initFacts = Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
initBlock f
initFacts
where
go :: Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go (BCons CmmNode O O
node1 Block CmmNode O O
block1) !f
fact1 = (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
rewriteOO CmmNode O O
node1 (f -> UniqSM (Block CmmNode O O, f))
-> (f -> UniqSM (Block CmmNode O O, f))
-> f
-> UniqSM (Block CmmNode O O, f)
forall (m :: * -> *) t (n :: Extensibility -> Extensibility -> *) b
t.
Monad m =>
(t -> m (Block n O O, b))
-> (t -> m (Block n O O, t)) -> t -> m (Block n O O, b)
`comp` Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
block1) f
fact1
go (BSnoc Block CmmNode O O
block1 CmmNode O O
node1) !f
fact1 = (Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
block1 (f -> UniqSM (Block CmmNode O O, f))
-> (f -> UniqSM (Block CmmNode O O, f))
-> f
-> UniqSM (Block CmmNode O O, f)
forall (m :: * -> *) t (n :: Extensibility -> Extensibility -> *) b
t.
Monad m =>
(t -> m (Block n O O, b))
-> (t -> m (Block n O O, t)) -> t -> m (Block n O O, b)
`comp` CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
rewriteOO CmmNode O O
node1) f
fact1
go (BCat Block CmmNode O O
blockA1 Block CmmNode O O
blockB1) !f
fact1 = (Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
blockA1 (f -> UniqSM (Block CmmNode O O, f))
-> (f -> UniqSM (Block CmmNode O O, f))
-> f
-> UniqSM (Block CmmNode O O, f)
forall (m :: * -> *) t (n :: Extensibility -> Extensibility -> *) b
t.
Monad m =>
(t -> m (Block n O O, b))
-> (t -> m (Block n O O, t)) -> t -> m (Block n O O, b)
`comp` Block CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
go Block CmmNode O O
blockB1) f
fact1
go (BMiddle CmmNode O O
node) !f
fact1 = CmmNode O O -> f -> UniqSM (Block CmmNode O O, f)
rewriteOO CmmNode O O
node f
fact1
go Block CmmNode O O
BNil !f
fact = (Block CmmNode O O, f) -> UniqSM (Block CmmNode O O, f)
forall (m :: * -> *) a. Monad m => a -> m a
return (Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *). Block n O O
BNil, f
fact)
comp :: (t -> m (Block n O O, b))
-> (t -> m (Block n O O, t)) -> t -> m (Block n O O, b)
comp t -> m (Block n O O, b)
rew1 t -> m (Block n O O, t)
rew2 = \t
f1 -> do
(Block n O O
b, t
f2) <- t -> m (Block n O O, t)
rew2 t
f1
(Block n O O
a, !b
f3) <- t -> m (Block n O O, b)
rew1 t
f2
let !c :: Block n O O
c = Block n O O -> Block n O O -> Block n O O
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> Block n O O -> Block n O O
joinBlocksOO Block n O O
a Block n O O
b
(Block n O O, b) -> m (Block n O O, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Block n O O
c, b
f3)
{-# INLINE comp #-}
{-# INLINABLE foldRewriteNodesBwdOO #-}
joinBlocksOO :: Block n O O -> Block n O O -> Block n O O
joinBlocksOO :: Block n O O -> Block n O O -> Block n O O
joinBlocksOO Block n O O
BNil Block n O O
b = Block n O O
b
joinBlocksOO Block n O O
b Block n O O
BNil = Block n O O
b
joinBlocksOO (BMiddle n O O
n) Block n O O
b = n O O -> Block n O O -> Block n O O
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n O O -> Block n O x -> Block n O x
blockCons n O O
n Block n O O
b
joinBlocksOO Block n O O
b (BMiddle n O O
n) = Block n O O -> n O O -> Block n O O
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O O -> Block n e O
blockSnoc Block n O O
b n O O
n
joinBlocksOO Block n O O
b1 Block n O O
b2 = Block n O O -> Block n O O -> Block n O O
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> Block n O O -> Block n O O
BCat Block n O O
b1 Block n O O
b2
type IntHeap = IntSet