{-# LANGUAGE GADTs #-}
module GHC.Cmm.Dominators
(
DominatorSet(..)
, GraphWithDominators(..)
, RPNum
, graphWithDominators
, graphMap
, gwdRPNumber
, gwdDominatorsOf
, gwdDominatorTree
, dominatorsMember
, intersectDominators
)
where
import GHC.Prelude
import Data.Array.IArray
import qualified Data.Tree as Tree
import Data.Word
import qualified GHC.CmmToAsm.CFG.Dominators as LT
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm
import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>))
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Word64 (intToWord64)
import qualified GHC.Data.Word64Map as WM
import qualified GHC.Data.Word64Set as WS
data DominatorSet = ImmediateDominator { DominatorSet -> Label
ds_label :: Label
, DominatorSet -> DominatorSet
ds_parent :: DominatorSet
}
| EntryNode
deriving (DominatorSet -> DominatorSet -> Bool
(DominatorSet -> DominatorSet -> Bool)
-> (DominatorSet -> DominatorSet -> Bool) -> Eq DominatorSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DominatorSet -> DominatorSet -> Bool
== :: DominatorSet -> DominatorSet -> Bool
$c/= :: DominatorSet -> DominatorSet -> Bool
/= :: DominatorSet -> DominatorSet -> Bool
Eq)
instance Outputable DominatorSet where
ppr :: DominatorSet -> SDoc
ppr DominatorSet
EntryNode = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"entry"
ppr (ImmediateDominator Label
l DominatorSet
parent) = Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DominatorSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr DominatorSet
parent
newtype RPNum = RPNum Int
deriving (RPNum -> RPNum -> Bool
(RPNum -> RPNum -> Bool) -> (RPNum -> RPNum -> Bool) -> Eq RPNum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RPNum -> RPNum -> Bool
== :: RPNum -> RPNum -> Bool
$c/= :: RPNum -> RPNum -> Bool
/= :: RPNum -> RPNum -> Bool
Eq, Eq RPNum
Eq RPNum =>
(RPNum -> RPNum -> Ordering)
-> (RPNum -> RPNum -> Bool)
-> (RPNum -> RPNum -> Bool)
-> (RPNum -> RPNum -> Bool)
-> (RPNum -> RPNum -> Bool)
-> (RPNum -> RPNum -> RPNum)
-> (RPNum -> RPNum -> RPNum)
-> Ord RPNum
RPNum -> RPNum -> Bool
RPNum -> RPNum -> Ordering
RPNum -> RPNum -> RPNum
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RPNum -> RPNum -> Ordering
compare :: RPNum -> RPNum -> Ordering
$c< :: RPNum -> RPNum -> Bool
< :: RPNum -> RPNum -> Bool
$c<= :: RPNum -> RPNum -> Bool
<= :: RPNum -> RPNum -> Bool
$c> :: RPNum -> RPNum -> Bool
> :: RPNum -> RPNum -> Bool
$c>= :: RPNum -> RPNum -> Bool
>= :: RPNum -> RPNum -> Bool
$cmax :: RPNum -> RPNum -> RPNum
max :: RPNum -> RPNum -> RPNum
$cmin :: RPNum -> RPNum -> RPNum
min :: RPNum -> RPNum -> RPNum
Ord)
instance Show RPNum where
show :: RPNum -> String
show (RPNum Int
i) = String
"RP" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
instance Outputable RPNum where
ppr :: RPNum -> SDoc
ppr (RPNum Int
i) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RP", Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i]
dominatorsMember :: Label -> DominatorSet -> Bool
dominatorsMember :: Label -> DominatorSet -> Bool
dominatorsMember Label
lbl (ImmediateDominator Label
l DominatorSet
p) = Label
l Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
lbl Bool -> Bool -> Bool
|| Label -> DominatorSet -> Bool
dominatorsMember Label
lbl DominatorSet
p
dominatorsMember Label
_ DominatorSet
EntryNode = Bool
False
intersectDominators :: DominatorSet -> DominatorSet -> DominatorSet
intersectDominators :: DominatorSet -> DominatorSet -> DominatorSet
intersectDominators DominatorSet
ds DominatorSet
ds' = [Label] -> [Label] -> DominatorSet -> DominatorSet
commonPrefix (DominatorSet -> [Label] -> [Label]
revDoms DominatorSet
ds []) (DominatorSet -> [Label] -> [Label]
revDoms DominatorSet
ds' []) DominatorSet
EntryNode
where revDoms :: DominatorSet -> [Label] -> [Label]
revDoms DominatorSet
EntryNode [Label]
prev = [Label]
prev
revDoms (ImmediateDominator Label
lbl DominatorSet
doms) [Label]
prev = DominatorSet -> [Label] -> [Label]
revDoms DominatorSet
doms (Label
lblLabel -> [Label] -> [Label]
forall a. a -> [a] -> [a]
:[Label]
prev)
commonPrefix :: [Label] -> [Label] -> DominatorSet -> DominatorSet
commonPrefix (Label
a:[Label]
as) (Label
b:[Label]
bs) DominatorSet
doms
| Label
a Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
b = [Label] -> [Label] -> DominatorSet -> DominatorSet
commonPrefix [Label]
as [Label]
bs (Label -> DominatorSet -> DominatorSet
ImmediateDominator Label
a DominatorSet
doms)
commonPrefix [Label]
_ [Label]
_ DominatorSet
doms = DominatorSet
doms
data GraphWithDominators node =
GraphWithDominators { forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> GenCmmGraph node
gwd_graph :: GenCmmGraph node
, forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> LabelMap DominatorSet
gwd_dominators :: LabelMap DominatorSet
, forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> LabelMap RPNum
gwd_rpnumbering :: LabelMap RPNum
}
graphWithDominators :: forall node .
(NonLocal node, HasDebugCallStack)
=> GenCmmGraph node
-> GraphWithDominators node
graphWithDominators :: forall (node :: Extensibility -> Extensibility -> *).
(NonLocal node, HasDebugCallStack) =>
GenCmmGraph node -> GraphWithDominators node
graphWithDominators GenCmmGraph node
g = GenCmmGraph node
-> LabelMap DominatorSet
-> LabelMap RPNum
-> GraphWithDominators node
forall (node :: Extensibility -> Extensibility -> *).
GenCmmGraph node
-> LabelMap DominatorSet
-> LabelMap RPNum
-> GraphWithDominators node
GraphWithDominators ([Block node C C] -> GenCmmGraph node -> GenCmmGraph node
forall (node :: Extensibility -> Extensibility -> *).
NonLocal node =>
[Block node C C] -> GenCmmGraph node -> GenCmmGraph node
reachable [Block node C C]
rpblocks GenCmmGraph node
g) LabelMap DominatorSet
dmap LabelMap RPNum
rpmap
where rpblocks :: [Block node C C]
rpblocks = LabelMap (Block node C C) -> Label -> [Block node C C]
forall (block :: Extensibility -> Extensibility -> *).
NonLocal block =>
LabelMap (block C C) -> Label -> [block C C]
revPostorderFrom (GenCmmGraph node -> LabelMap (Block node C C)
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> LabelMap (Block n C C)
graphMap GenCmmGraph node
g) (GenCmmGraph node -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry GenCmmGraph node
g)
rplabels' :: [Label]
rplabels' = (Block node C C -> Label) -> [Block node C C] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map Block node C C -> Label
forall (x :: Extensibility). Block node C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel [Block node C C]
rpblocks
rplabels :: Array Word64 Label
rplabels :: Array Word64 Label
rplabels = (Word64, Word64) -> [Label] -> Array Word64 Label
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Word64, Word64)
bounds [Label]
rplabels'
rpmap :: LabelMap RPNum
rpmap :: LabelMap RPNum
rpmap = [(Label, RPNum)] -> LabelMap RPNum
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, RPNum)] -> LabelMap RPNum)
-> [(Label, RPNum)] -> LabelMap RPNum
forall a b. (a -> b) -> a -> b
$ (Block node C C -> Int -> (Label, RPNum))
-> [Block node C C] -> [Int] -> [(Label, RPNum)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Block node C C -> Int -> (Label, RPNum)
forall {thing :: Extensibility -> Extensibility -> *}
{x :: Extensibility}.
NonLocal thing =>
thing C x -> Int -> (Label, RPNum)
kvpair [Block node C C]
rpblocks [Int
0..]
where kvpair :: thing C x -> Int -> (Label, RPNum)
kvpair thing C x
block Int
i = (thing C x -> Label
forall (x :: Extensibility). thing C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C x
block, Int -> RPNum
RPNum Int
i)
labelIndex :: Label -> Word64
labelIndex :: Label -> Word64
labelIndex = (Label -> LabelMap Word64 -> Word64)
-> LabelMap Word64 -> Label -> Word64
forall a b c. (a -> b -> c) -> b -> a -> c
flip Label -> LabelMap Word64 -> Word64
forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn LabelMap Word64
imap
where imap :: LabelMap Word64
imap :: LabelMap Word64
imap = [(Label, Word64)] -> LabelMap Word64
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, Word64)] -> LabelMap Word64)
-> [(Label, Word64)] -> LabelMap Word64
forall a b. (a -> b) -> a -> b
$ [Label] -> [Word64] -> [(Label, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Label]
rplabels' [Word64
0..]
blockIndex :: Block node C x -> Word64
blockIndex = Label -> Word64
labelIndex (Label -> Word64)
-> (Block node C x -> Label) -> Block node C x -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block node C x -> Label
forall (x :: Extensibility). Block node C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel
bounds :: (Word64, Word64)
bounds :: (Word64, Word64)
bounds = (Word64
0, Int -> Word64
HasDebugCallStack => Int -> Word64
intToWord64 ([Block node C C] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Block node C C]
rpblocks Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
ltGraph :: [Block node C C] -> LT.Graph
ltGraph :: [Block node C C] -> Graph
ltGraph [] = Graph
forall a. Word64Map a
WM.empty
ltGraph (Block node C C
block:[Block node C C]
blocks) =
Word64 -> Word64Set -> Graph -> Graph
forall a. Word64 -> a -> Word64Map a -> Word64Map a
WM.insert
(Block node C C -> Word64
forall {x :: Extensibility}. Block node C x -> Word64
blockIndex Block node C C
block)
([Word64] -> Word64Set
WS.fromList ([Word64] -> Word64Set) -> [Word64] -> Word64Set
forall a b. (a -> b) -> a -> b
$ (Label -> Word64) -> [Label] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Label -> Word64
labelIndex ([Label] -> [Word64]) -> [Label] -> [Word64]
forall a b. (a -> b) -> a -> b
$ Block node C C -> [Label]
forall (e :: Extensibility). Block node e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors Block node C C
block)
([Block node C C] -> Graph
ltGraph [Block node C C]
blocks)
idom_array :: Array Word64 LT.Node
idom_array :: Array Word64 Word64
idom_array = (Word64, Word64) -> [(Word64, Word64)] -> Array Word64 Word64
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Word64, Word64)
bounds ([(Word64, Word64)] -> Array Word64 Word64)
-> [(Word64, Word64)] -> Array Word64 Word64
forall a b. (a -> b) -> a -> b
$ Rooted -> [(Word64, Word64)]
LT.idom (Word64
0, [Block node C C] -> Graph
ltGraph [Block node C C]
rpblocks)
domSet :: Word64 -> DominatorSet
domSet Word64
0 = DominatorSet
EntryNode
domSet Word64
i = Label -> DominatorSet -> DominatorSet
ImmediateDominator (Array Word64 Label
rplabels Array Word64 Label -> Word64 -> Label
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word64
d) (Array Word64 DominatorSet
doms Array Word64 DominatorSet -> Word64 -> DominatorSet
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word64
d)
where d :: Word64
d = Array Word64 Word64
idom_array Array Word64 Word64 -> Word64 -> Word64
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Word64
i
doms :: Array Word64 DominatorSet
doms = (Word64, Word64)
-> (Word64 -> DominatorSet) -> Array Word64 DominatorSet
forall i e. Ix i => (i, i) -> (i -> e) -> Array i e
tabulate (Word64, Word64)
bounds Word64 -> DominatorSet
domSet
dmap :: LabelMap DominatorSet
dmap = [(Label, DominatorSet)] -> LabelMap DominatorSet
forall v. [(Label, v)] -> LabelMap v
mapFromList ([(Label, DominatorSet)] -> LabelMap DominatorSet)
-> [(Label, DominatorSet)] -> LabelMap DominatorSet
forall a b. (a -> b) -> a -> b
$ (Label -> Word64 -> (Label, DominatorSet))
-> [Label] -> [Word64] -> [(Label, DominatorSet)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Label
lbl Word64
i -> (Label
lbl, Word64 -> DominatorSet
domSet Word64
i)) [Label]
rplabels' [Word64
0..]
reachable :: NonLocal node => [Block node C C] -> GenCmmGraph node -> GenCmmGraph node
reachable :: forall (node :: Extensibility -> Extensibility -> *).
NonLocal node =>
[Block node C C] -> GenCmmGraph node -> GenCmmGraph node
reachable [Block node C C]
blocks GenCmmGraph node
g = GenCmmGraph node
g { g_graph = GMany NothingO blockmap NothingO }
where blockmap :: Body' LabelMap Block node
blockmap = [(Label, Block node C C)] -> Body' LabelMap Block node
forall v. [(Label, v)] -> LabelMap v
mapFromList [(Block node C C -> Label
forall (x :: Extensibility). Block node C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block node C C
b, Block node C C
b) | Block node C C
b <- [Block node C C]
blocks]
graphMap :: GenCmmGraph n -> LabelMap (Block n C C)
graphMap :: forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> LabelMap (Block n C C)
graphMap (CmmGraph { g_graph :: forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Graph' s Block n C C
g_graph = GMany MaybeO C (Block n O C)
NothingO Body' LabelMap Block n
blockmap MaybeO C (Block n C O)
NothingO }) = Body' LabelMap Block n
blockmap
gwdRPNumber :: HasDebugCallStack => GraphWithDominators node -> Label -> RPNum
gwdRPNumber :: forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> RPNum
gwdRPNumber GraphWithDominators node
g Label
l = Label -> LabelMap RPNum -> RPNum
forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
l (GraphWithDominators node -> LabelMap RPNum
forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> LabelMap RPNum
gwd_rpnumbering GraphWithDominators node
g)
findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn :: forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
lbl = a -> Label -> LabelMap a -> a
forall a. a -> Label -> LabelMap a -> a
mapFindWithDefault a
failed Label
lbl
where failed :: a
failed =
String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"label not found in result of analysis" (Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
lbl)
gwdDominatorsOf :: HasDebugCallStack => GraphWithDominators node -> Label -> DominatorSet
gwdDominatorsOf :: forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> DominatorSet
gwdDominatorsOf GraphWithDominators node
g Label
lbl = Label -> LabelMap DominatorSet -> DominatorSet
forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
lbl (GraphWithDominators node -> LabelMap DominatorSet
forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> LabelMap DominatorSet
gwd_dominators GraphWithDominators node
g)
gwdDominatorTree :: GraphWithDominators node -> Tree.Tree Label
gwdDominatorTree :: forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> Tree Label
gwdDominatorTree GraphWithDominators node
gwd = Label -> Tree Label
subtreeAt (GenGenCmmGraph LabelMap node -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry (GraphWithDominators node -> GenGenCmmGraph LabelMap node
forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> GenCmmGraph node
gwd_graph GraphWithDominators node
gwd))
where subtreeAt :: Label -> Tree Label
subtreeAt Label
label = Label -> [Tree Label] -> Tree Label
forall a. a -> [Tree a] -> Tree a
Tree.Node Label
label ([Tree Label] -> Tree Label) -> [Tree Label] -> Tree Label
forall a b. (a -> b) -> a -> b
$ (Label -> Tree Label) -> [Label] -> [Tree Label]
forall a b. (a -> b) -> [a] -> [b]
map Label -> Tree Label
subtreeAt ([Label] -> [Tree Label]) -> [Label] -> [Tree Label]
forall a b. (a -> b) -> a -> b
$ Label -> [Label]
children Label
label
children :: Label -> [Label]
children Label
l = [Label] -> Label -> LabelMap [Label] -> [Label]
forall a. a -> Label -> LabelMap a -> a
mapFindWithDefault [] Label
l LabelMap [Label]
child_map
child_map :: LabelMap [Label]
child_map :: LabelMap [Label]
child_map = (LabelMap [Label] -> Label -> DominatorSet -> LabelMap [Label])
-> LabelMap [Label] -> LabelMap DominatorSet -> LabelMap [Label]
forall t b. (t -> Label -> b -> t) -> t -> LabelMap b -> t
mapFoldlWithKey LabelMap [Label] -> Label -> DominatorSet -> LabelMap [Label]
forall {a}. LabelMap [a] -> a -> DominatorSet -> LabelMap [a]
addParent LabelMap [Label]
forall v. LabelMap v
mapEmpty (LabelMap DominatorSet -> LabelMap [Label])
-> LabelMap DominatorSet -> LabelMap [Label]
forall a b. (a -> b) -> a -> b
$ GraphWithDominators node -> LabelMap DominatorSet
forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> LabelMap DominatorSet
gwd_dominators GraphWithDominators node
gwd
where addParent :: LabelMap [a] -> a -> DominatorSet -> LabelMap [a]
addParent LabelMap [a]
cm a
_ DominatorSet
EntryNode = LabelMap [a]
cm
addParent LabelMap [a]
cm a
lbl (ImmediateDominator Label
p DominatorSet
_) =
([a] -> [a] -> [a]) -> Label -> [a] -> LabelMap [a] -> LabelMap [a]
forall v. (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v
mapInsertWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) Label
p [a
lbl] LabelMap [a]
cm
tabulate :: (Ix i) => (i, i) -> (i -> e) -> Array i e
tabulate :: forall i e. Ix i => (i, i) -> (i -> e) -> Array i e
tabulate (i, i)
b i -> e
f = (i, i) -> [e] -> Array i e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (i, i)
b ([e] -> Array i e) -> [e] -> Array i e
forall a b. (a -> b) -> a -> b
$ (i -> e) -> [i] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map i -> e
f ([i] -> [e]) -> [i] -> [e]
forall a b. (a -> b) -> a -> b
$ (i, i) -> [i]
forall a. Ix a => (a, a) -> [a]
range (i, i)
b