{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module GHC.Cmm.Reducibility
( Reducibility(..)
, reducibility
, asReducible
)
where
import GHC.Prelude hiding (splitAt, succ)
import Control.Monad
import Data.List (nub)
import Data.Maybe
import Data.Semigroup
import qualified Data.Sequence as Seq
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dominators
import GHC.Cmm.Dataflow.Graph hiding (addBlock)
import GHC.Cmm.Dataflow.Label
import GHC.Data.Graph.Collapse
import GHC.Data.Graph.Inductive.Graph
import GHC.Data.Graph.Inductive.PatriciaTree
import GHC.Types.Unique.Supply
import GHC.Utils.Panic
data Reducibility = Reducible | Irreducible
deriving (Reducibility -> Reducibility -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Reducibility -> Reducibility -> Bool
$c/= :: Reducibility -> Reducibility -> Bool
== :: Reducibility -> Reducibility -> Bool
$c== :: Reducibility -> Reducibility -> Bool
Eq, Node -> Reducibility -> ShowS
[Reducibility] -> ShowS
Reducibility -> String
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reducibility] -> ShowS
$cshowList :: [Reducibility] -> ShowS
show :: Reducibility -> String
$cshow :: Reducibility -> String
showsPrec :: Node -> Reducibility -> ShowS
$cshowsPrec :: Node -> Reducibility -> ShowS
Show)
reducibility :: NonLocal node
=> GraphWithDominators node
-> Reducibility
reducibility :: forall (node :: Extensibility -> Extensibility -> *).
NonLocal node =>
GraphWithDominators node -> Reducibility
reducibility GraphWithDominators node
gwd =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Block node C C -> Bool
goodBlock LabelMap (Block node C C)
blockmap then Reducibility
Reducible else Reducibility
Irreducible
where goodBlock :: Block node C C -> Bool
goodBlock Block node C C
b = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Label -> Label -> Bool
goodEdge (forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block node C C
b)) (forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors Block node C C
b)
goodEdge :: Label -> Label -> Bool
goodEdge Label
from Label
to = Label -> RPNum
rpnum Label
to forall a. Ord a => a -> a -> Bool
> Label -> RPNum
rpnum Label
from Bool -> Bool -> Bool
|| Label
to Label -> Label -> Bool
`dominates` Label
from
rpnum :: Label -> RPNum
rpnum = forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> RPNum
gwdRPNumber GraphWithDominators node
gwd
blockmap :: LabelMap (Block node C C)
blockmap = forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> LabelMap (Block n C C)
graphMap forall a b. (a -> b) -> a -> b
$ forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> GenCmmGraph node
gwd_graph GraphWithDominators node
gwd
dominators :: Label -> DominatorSet
dominators = forall (node :: Extensibility -> Extensibility -> *).
HasDebugCallStack =>
GraphWithDominators node -> Label -> DominatorSet
gwdDominatorsOf GraphWithDominators node
gwd
dominates :: Label -> Label -> Bool
dominates Label
lbl Label
blockname =
Label
lbl forall a. Eq a => a -> a -> Bool
== Label
blockname Bool -> Bool -> Bool
|| Label -> DominatorSet -> Bool
dominatorsMember Label
lbl (Label -> DominatorSet
dominators Label
blockname)
asReducible :: GraphWithDominators CmmNode
-> UniqSM (GraphWithDominators CmmNode)
asReducible :: GraphWithDominators CmmNode -> UniqSM (GraphWithDominators CmmNode)
asReducible GraphWithDominators CmmNode
gwd = case forall (node :: Extensibility -> Extensibility -> *).
NonLocal node =>
GraphWithDominators node -> Reducibility
reducibility GraphWithDominators CmmNode
gwd of
Reducibility
Reducible -> forall (m :: * -> *) a. Monad m => a -> m a
return GraphWithDominators CmmNode
gwd
Reducibility
Irreducible -> GraphWithDominators CmmNode -> GraphWithDominators CmmNode
assertReducible forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphWithDominators CmmNode -> UniqSM (GraphWithDominators CmmNode)
nodeSplit GraphWithDominators CmmNode
gwd
assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode
assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode
assertReducible GraphWithDominators CmmNode
gwd = case forall (node :: Extensibility -> Extensibility -> *).
NonLocal node =>
GraphWithDominators node -> Reducibility
reducibility GraphWithDominators CmmNode
gwd of
Reducibility
Reducible -> GraphWithDominators CmmNode
gwd
Reducibility
Irreducible -> forall a. HasCallStack => String -> a
panic String
"result not reducible"
nodeSplit :: GraphWithDominators CmmNode
-> UniqSM (GraphWithDominators CmmNode)
nodeSplit :: GraphWithDominators CmmNode -> UniqSM (GraphWithDominators CmmNode)
nodeSplit GraphWithDominators CmmNode
gwd =
forall (node :: Extensibility -> Extensibility -> *).
(NonLocal node, HasDebugCallStack) =>
GenCmmGraph node -> GraphWithDominators node
graphWithDominators forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label -> Gr CmmSuper () -> CmmGraph
inflate (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NullCollapseViz a -> UniqSM a
runNullCollapse NullCollapseViz (Gr CmmSuper ())
collapsed
where g :: CmmGraph
g = forall (node :: Extensibility -> Extensibility -> *).
GraphWithDominators node -> GenCmmGraph node
gwd_graph GraphWithDominators CmmNode
gwd
collapsed :: NullCollapseViz (Gr CmmSuper ())
collapsed :: NullCollapseViz (Gr CmmSuper ())
collapsed = forall (gr :: * -> * -> *) s (m :: * -> *).
(DynGraph gr, Supernode s m, VizCollapseMonad m gr s) =>
gr s () -> m (gr s ())
collapseInductiveGraph (CmmGraph -> Gr CmmSuper ()
cgraphOfCmm CmmGraph
g)
type CGraph = Gr CmmSuper ()
inflate :: Label -> CGraph -> CmmGraph
inflate :: Label -> Gr CmmSuper () -> CmmGraph
inflate Label
entry Gr CmmSuper ()
cg = forall (n :: Extensibility -> Extensibility -> *).
Label -> Graph n C C -> GenCmmGraph n
CmmGraph Label
entry Graph' Block CmmNode C C
graph
where graph :: Graph' Block CmmNode C C
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 CmmBlock
body forall t. MaybeO C t
NothingO
body :: LabelMap CmmBlock
body :: LabelMap CmmBlock
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\LabelMap CmmBlock
map CmmBlock
block -> forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block) CmmBlock
block LabelMap CmmBlock
map) forall (map :: * -> *) a. IsMap map => map a
mapEmpty forall a b. (a -> b) -> a -> b
$
CmmSuper -> Seq CmmBlock
blocks CmmSuper
super
super :: CmmSuper
super = case forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr CmmSuper ()
cg of
[(Node
_, CmmSuper
s)] -> CmmSuper
s
[LNode CmmSuper]
_ -> forall a. HasCallStack => String -> a
panic String
"graph given to `inflate` is not singleton"
cgraphOfCmm :: CmmGraph -> CGraph
cgraphOfCmm :: CmmGraph -> Gr CmmSuper ()
cgraphOfCmm CmmGraph
g = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Gr CmmSuper () -> (Node, CmmBlock) -> Gr CmmSuper ()
addSuccEdges (forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode CmmSuper]
cnodes []) [(Node, CmmBlock)]
blocks
where blocks :: [(Node, CmmBlock)]
blocks = forall a b. [a] -> [b] -> [(a, b)]
zip [Node
0..] forall a b. (a -> b) -> a -> b
$ 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 CmmGraph
g) (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
g)
cnodes :: [LNode CmmSuper]
cnodes = [(Node
k, CmmBlock -> CmmSuper
super CmmBlock
block) | (Node
k, CmmBlock
block) <- [(Node, CmmBlock)]
blocks]
where super :: CmmBlock -> CmmSuper
super CmmBlock
block = Label -> Seq CmmBlock -> CmmSuper
Nodes (forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block) (forall a. a -> Seq a
Seq.singleton CmmBlock
block)
labelNumber :: Label -> Node
labelNumber = \Label
lbl -> forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
lbl LabelMap Node
numbers
where numbers :: LabelMap Int
numbers :: LabelMap Node
numbers = 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]
map forall {thing :: Extensibility -> Extensibility -> *} {b}
{x :: Extensibility}.
NonLocal thing =>
(b, thing C x) -> (Label, b)
swap [(Node, CmmBlock)]
blocks
swap :: (b, thing C x) -> (Label, b)
swap (b
k, thing C x
block) = (forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel thing C x
block, b
k)
addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph
addSuccEdges :: Gr CmmSuper () -> (Node, CmmBlock) -> Gr CmmSuper ()
addSuccEdges Gr CmmSuper ()
graph (Node
k, CmmBlock
block) =
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [(Node
k, Label -> Node
labelNumber Label
lbl, ()) | Label
lbl <- forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors CmmBlock
block] Gr CmmSuper ()
graph
type Seq = Seq.Seq
data CmmSuper
= Nodes { CmmSuper -> Label
label :: Label
, CmmSuper -> Seq CmmBlock
blocks :: Seq CmmBlock
}
instance Semigroup CmmSuper where
CmmSuper
s <> :: CmmSuper -> CmmSuper -> CmmSuper
<> CmmSuper
s' = Label -> Seq CmmBlock -> CmmSuper
Nodes (CmmSuper -> Label
label CmmSuper
s) (CmmSuper -> Seq CmmBlock
blocks CmmSuper
s forall a. Semigroup a => a -> a -> a
<> CmmSuper -> Seq CmmBlock
blocks CmmSuper
s')
instance PureSupernode CmmSuper where
superLabel :: CmmSuper -> Label
superLabel = CmmSuper -> Label
label
mapLabels :: (Label -> Label) -> CmmSuper -> CmmSuper
mapLabels = (Label -> Label) -> CmmSuper -> CmmSuper
changeLabels
instance Supernode CmmSuper NullCollapseViz where
freshen :: CmmSuper -> NullCollapseViz CmmSuper
freshen CmmSuper
s = forall (m :: * -> *) a. MonadUniqSM m => UniqSM a -> m a
liftUniqSM forall a b. (a -> b) -> a -> b
$ CmmSuper -> UniqSM CmmSuper
relabel CmmSuper
s
definedLabels :: CmmSuper -> Seq Label
definedLabels :: CmmSuper -> Seq Label
definedLabels = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmSuper -> Seq CmmBlock
blocks
changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper)
changeLabels :: (Label -> Label) -> CmmSuper -> CmmSuper
changeLabels Label -> Label
f (Nodes Label
l Seq CmmBlock
blocks) = Label -> Seq CmmBlock -> CmmSuper
Nodes (Label -> Label
f Label
l) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Label -> Label) -> CmmBlock -> CmmBlock
changeBlockLabels Label -> Label
f) Seq CmmBlock
blocks)
changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock
changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock
changeBlockLabels Label -> Label
f CmmBlock
block = forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin CmmNode C O
entry' Block CmmNode O O
middle CmmNode O C
exit'
where (CmmNode C O
entry, Block CmmNode O O
middle, CmmNode O C
exit) = forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
entry' :: CmmNode C O
entry' = let CmmEntry Label
l CmmTickScope
scope = CmmNode C O
entry
in Label -> CmmTickScope -> CmmNode C O
CmmEntry (Label -> Label
f Label
l) CmmTickScope
scope
exit' :: CmmNode O C
exit' = case CmmNode O C
exit of
CmmCall { cml_cont :: CmmNode O C -> Maybe Label
cml_cont = Just Label
l } -> CmmNode O C
exit { cml_cont :: Maybe Label
cml_cont = forall a. a -> Maybe a
Just (Label -> Label
f Label
l) }
CmmForeignCall { succ :: CmmNode O C -> Label
succ = Label
l } -> CmmNode O C
exit { succ :: Label
succ = Label -> Label
f Label
l }
CmmNode O C
_ -> (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors Label -> Label
f CmmNode O C
exit
relabel :: CmmSuper -> UniqSM CmmSuper
relabel :: CmmSuper -> UniqSM CmmSuper
relabel CmmSuper
node = do
LabelMap Label
finite_map <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LabelMap Label -> Label -> UniqSM (LabelMap Label)
addPair forall (map :: * -> *) a. IsMap map => map a
mapEmpty forall a b. (a -> b) -> a -> b
$ CmmSuper -> Seq Label
definedLabels CmmSuper
node
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Label -> Label) -> CmmSuper -> CmmSuper
changeLabels (LabelMap Label -> Label -> Label
labelChanger LabelMap Label
finite_map) CmmSuper
node
where addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label)
addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label)
addPair LabelMap Label
map Label
old = do Label
new <- forall (m :: * -> *). MonadUnique m => m Label
newBlockId
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
old Label
new LabelMap Label
map
labelChanger :: LabelMap Label -> (Label -> Label)
labelChanger :: LabelMap Label -> Label -> Label
labelChanger LabelMap Label
mapping = \Label
lbl -> forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault Label
lbl Label
lbl LabelMap Label
mapping