{-# LANGUAGE GADTs #-}

module GHC.Cmm.Dominators
  (
  -- * Dominator analysis and representation of results
    DominatorSet(..)
  , GraphWithDominators(..)
  , RPNum
  , graphWithDominators

  -- * Utility functions on graphs or graphs-with-dominators
  , graphMap
  , gwdRPNumber
  , gwdDominatorsOf
  , gwdDominatorTree

  -- * Utility functions on dominator sets
  , dominatorsMember
  , intersectDominators
  )
where

import GHC.Prelude

import Data.Array.IArray
import Data.Foldable()
import qualified Data.Tree as Tree

import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS

import qualified GHC.CmmToAsm.CFG.Dominators as LT

import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
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


-- | =Dominator sets
--
-- Node X dominates node Y if and only if every path from the entry to
-- Y includes X.  Node Y technically dominates itself, but it is
-- never included in the *representation* of its dominator set.
--
-- A dominator set is represented as a linked list in which each node
-- points to its *immediate* dominator, which is its parent in the
-- dominator tree.  In many circumstances the immediate dominator
-- will be the only dominator of interest.

data DominatorSet = ImmediateDominator { DominatorSet -> Label
ds_label  :: Label -- ^ Label of the immediate dominator.
                                       , DominatorSet -> DominatorSet
ds_parent :: DominatorSet -- ^ Set of nodes dominating the immediate dominator.
                                       }
                  | EntryNode
  deriving (DominatorSet -> DominatorSet -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DominatorSet -> DominatorSet -> Bool
$c/= :: DominatorSet -> DominatorSet -> Bool
== :: DominatorSet -> DominatorSet -> Bool
$c== :: DominatorSet -> DominatorSet -> Bool
Eq)

instance Outputable DominatorSet where
  ppr :: DominatorSet -> SDoc
ppr DominatorSet
EntryNode = forall doc. IsLine doc => String -> doc
text String
"entry"
  ppr (ImmediateDominator Label
l DominatorSet
parent) = forall a. Outputable a => a -> SDoc
ppr Label
l forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"->" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr DominatorSet
parent



-- | Reverse postorder number of a node in a CFG
newtype RPNum = RPNum Int
  deriving (RPNum -> RPNum -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RPNum -> RPNum -> Bool
$c/= :: RPNum -> RPNum -> Bool
== :: RPNum -> RPNum -> Bool
$c== :: RPNum -> RPNum -> Bool
Eq, Eq 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
min :: RPNum -> RPNum -> RPNum
$cmin :: RPNum -> RPNum -> RPNum
max :: RPNum -> RPNum -> RPNum
$cmax :: RPNum -> RPNum -> RPNum
>= :: RPNum -> RPNum -> Bool
$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
compare :: RPNum -> RPNum -> Ordering
$ccompare :: RPNum -> RPNum -> Ordering
Ord)
-- in reverse postorder, nodes closer to the entry have smaller numbers

instance Show RPNum where
  show :: RPNum -> String
show (RPNum Int
i) = String
"RP" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i

instance Outputable RPNum where
  ppr :: RPNum -> SDoc
ppr (RPNum Int
i) = forall doc. IsLine doc => [doc] -> doc
hcat [forall doc. IsLine doc => String -> doc
text String
"RP", forall doc. IsLine doc => Int -> doc
int Int
i]
   -- using `(<>)` would conflict with Semigroup



dominatorsMember :: Label -> DominatorSet -> Bool
-- ^ Use to tell if the given label is in the given
-- dominator set.  Which is to say, does the bloc
-- with with given label _properly_ and _non-vacuously_
-- dominate the node whose dominator set this is?
--
-- Takes linear time in the height of the dominator tree,
-- but uses space efficiently.
dominatorsMember :: Label -> DominatorSet -> Bool
dominatorsMember Label
lbl (ImmediateDominator Label
l DominatorSet
p) = Label
l 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


-- | Intersect two dominator sets to produce a third dominator set.
-- This function takes time linear in the size of the sets.
-- As such it is inefficient and should be used only for things
-- like visualizations or linters.
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
lblforall a. a -> [a] -> [a]
:[Label]
prev)
        commonPrefix :: [Label] -> [Label] -> DominatorSet -> DominatorSet
commonPrefix (Label
a:[Label]
as) (Label
b:[Label]
bs) DominatorSet
doms
            | Label
a 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


-- | The result of dominator analysis.  Also includes a reverse
-- postorder numbering, which is needed for dominator analysis
-- and for other (downstream) analyses.
--
-- Invariant: Dominators, graph, and RP numberings include only *reachable* blocks.
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
                        }


-- | Call this function with a `CmmGraph` to get back the results of a
-- dominator analysis of that graph (as well as a reverse postorder
-- numbering).  The result also includes the subgraph of the original
-- graph that contains only the reachable blocks.
graphWithDominators :: forall node .
       (NonLocal node, HasDebugCallStack)
       => GenCmmGraph node
       -> GraphWithDominators node

-- The implementation uses the Lengauer-Tarjan algorithm from the x86
-- back end.

graphWithDominators :: forall (node :: Extensibility -> Extensibility -> *).
(NonLocal node, HasDebugCallStack) =>
GenCmmGraph node -> GraphWithDominators node
graphWithDominators GenCmmGraph node
g = forall (node :: Extensibility -> Extensibility -> *).
GenCmmGraph node
-> LabelMap DominatorSet
-> LabelMap RPNum
-> GraphWithDominators node
GraphWithDominators (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 = forall (block :: Extensibility -> Extensibility -> *).
NonLocal block =>
LabelMap (block C C) -> Label -> [block C C]
revPostorderFrom (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> LabelMap (Block n C C)
graphMap GenCmmGraph node
g) (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry GenCmmGraph node
g)
            rplabels' :: [Label]
rplabels' = forall a b. (a -> b) -> [a] -> [b]
map forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel [Block node C C]
rpblocks
            rplabels :: Array Int Label
            rplabels :: Array Int Label
rplabels = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int, Int)
bounds [Label]
rplabels'

            rpmap :: LabelMap RPNum
            rpmap :: LabelMap RPNum
rpmap = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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 = (forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C x
block, Int -> RPNum
RPNum Int
i)

            labelIndex :: Label -> Int
            labelIndex :: Label -> Int
labelIndex = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn LabelMap Int
imap
              where imap :: LabelMap Int
                    imap :: LabelMap Int
imap = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Label]
rplabels' [Int
0..]
            blockIndex :: Block node C x -> Int
blockIndex = Label -> Int
labelIndex forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel

            bounds :: (Int, Int)
bounds = (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Block node C C]
rpblocks forall a. Num a => a -> a -> a
- Int
1)

            ltGraph :: [Block node C C] -> LT.Graph
            ltGraph :: [Block node C C] -> Graph
ltGraph [] = forall a. IntMap a
IM.empty
            ltGraph (Block node C C
block:[Block node C C]
blocks) =
                forall a. Int -> a -> IntMap a -> IntMap a
IM.insert
                      (forall {x :: Extensibility}. Block node C x -> Int
blockIndex Block node C C
block)
                      ([Int] -> IntSet
IS.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Label -> Int
labelIndex forall a b. (a -> b) -> a -> b
$ 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 Int LT.Node
            idom_array :: Array Int Int
idom_array = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Int, Int)
bounds forall a b. (a -> b) -> a -> b
$ Rooted -> [(Int, Int)]
LT.idom (Int
0, [Block node C C] -> Graph
ltGraph [Block node C C]
rpblocks)

            domSet :: Int -> DominatorSet
domSet Int
0 = DominatorSet
EntryNode
            domSet Int
i = Label -> DominatorSet -> DominatorSet
ImmediateDominator (Array Int Label
rplabels forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
d) (Array Int DominatorSet
doms forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
d)
                where d :: Int
d = Array Int Int
idom_array forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
i
            doms :: Array Int DominatorSet
doms = forall i e. Ix i => (i, i) -> (i -> e) -> Array i e
tabulate (Int, Int)
bounds Int -> DominatorSet
domSet

            dmap :: LabelMap DominatorSet
dmap = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Label
lbl Int
i -> (Label
lbl, Int -> DominatorSet
domSet Int
i)) [Label]
rplabels' [Int
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 :: Graph node C C
g_graph = 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 forall t. MaybeO C t
NothingO LabelMap (Block node C C)
blockmap forall t. MaybeO C t
NothingO }
  where blockmap :: LabelMap (Block node C C)
blockmap = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [(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]


-- | =Utility functions

-- | Call `graphMap` to get the mapping from `Label` to `Block` that
-- is embedded in every `CmmGraph`.
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 (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Graph n C C
g_graph = GMany MaybeO C (Block n O C)
NothingO Body' Block n
blockmap MaybeO C (Block n C O)
NothingO }) = Body' Block n
blockmap

-- | Use `gwdRPNumber` on the result of the dominator analysis to get
-- a mapping from the `Label` of each reachable block to the reverse
-- postorder number of that block.
gwdRPNumber :: HasDebugCallStack => GraphWithDominators node -> Label -> RPNum
gwdRPNumber :: forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> RPNum
gwdRPNumber GraphWithDominators node
g Label
l = forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
l (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 = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault a
failed Label
lbl
  where failed :: a
failed =
            forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"label not found in result of analysis" (forall a. Outputable a => a -> SDoc
ppr Label
lbl)

-- | Use `gwdDominatorsOf` on the result of the dominator analysis to get
-- a mapping from the `Label` of each reachable block to the dominator
-- set (and the immediate dominator) of that block.  The
-- implementation is space-efficient: intersecting dominator
-- sets share the representation of their intersection.

gwdDominatorsOf :: HasDebugCallStack => GraphWithDominators node -> Label -> DominatorSet
gwdDominatorsOf :: forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> DominatorSet
gwdDominatorsOf GraphWithDominators node
g Label
lbl = forall a. HasDebugCallStack => Label -> LabelMap a -> a
findLabelIn Label
lbl (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 (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry (forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> GenCmmGraph node
gwd_graph GraphWithDominators node
gwd))
  where subtreeAt :: Label -> Tree Label
subtreeAt Label
label = forall a. a -> [Tree a] -> Tree a
Tree.Node Label
label forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Label -> Tree Label
subtreeAt forall a b. (a -> b) -> a -> b
$ Label -> [Label]
children Label
label
        children :: Label -> [Label]
children Label
l = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault [] Label
l LabelMap [Label]
child_map
        child_map :: LabelMap [Label]
        child_map :: LabelMap [Label]
child_map = forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey forall {map :: * -> *} {a}.
(KeyOf map ~ Label, IsMap map) =>
map [a] -> a -> DominatorSet -> map [a]
addParent forall (map :: * -> *) a. IsMap map => map a
mapEmpty forall a b. (a -> b) -> a -> b
$ forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> LabelMap DominatorSet
gwd_dominators GraphWithDominators node
gwd
          where addParent :: map [a] -> a -> DominatorSet -> map [a]
addParent map [a]
cm a
_ DominatorSet
EntryNode = map [a]
cm
                addParent map [a]
cm a
lbl (ImmediateDominator Label
p DominatorSet
_) =
                    forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith forall a. [a] -> [a] -> [a]
(++) Label
p [a
lbl] map [a]
cm


-- | Turn a function into an array.  Inspired by SML's `Array.tabulate`
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 = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (i, i)
b forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map i -> e
f forall a b. (a -> b) -> a -> b
$ forall a. Ix a => (a, a) -> [a]
range (i, i)
b