{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Data.Graph.Collapse
( PureSupernode(..)
, Supernode(..)
, collapseInductiveGraph
, VizCollapseMonad(..)
, NullCollapseViz(..)
, runNullCollapse
, MonadUniqDSM(..)
)
where
import GHC.Prelude
import Control.Exception
import Control.Monad
import Data.List (delete, union, insert, intersect)
import Data.Semigroup
import GHC.Cmm.Dataflow.Label
import GHC.Data.Graph.Inductive.Graph
import GHC.Types.Unique.DSM
import GHC.Utils.Panic hiding (assert)
class (MonadUniqDSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where
consumeByInGraph :: Node -> Node -> gr s () -> m ()
splitGraphAt :: gr s () -> LNode s -> m ()
finalGraph :: gr s () -> m ()
newtype NullCollapseViz a = NullCollapseViz { forall a. NullCollapseViz a -> UniqDSM a
unNCV :: UniqDSM a }
deriving ((forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b)
-> (forall a b. a -> NullCollapseViz b -> NullCollapseViz a)
-> Functor NullCollapseViz
forall a b. a -> NullCollapseViz b -> NullCollapseViz a
forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b
fmap :: forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b
$c<$ :: forall a b. a -> NullCollapseViz b -> NullCollapseViz a
<$ :: forall a b. a -> NullCollapseViz b -> NullCollapseViz a
Functor, Functor NullCollapseViz
Functor NullCollapseViz =>
(forall a. a -> NullCollapseViz a)
-> (forall a b.
NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b)
-> (forall a b c.
(a -> b -> c)
-> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c)
-> (forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b)
-> (forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a)
-> Applicative NullCollapseViz
forall a. a -> NullCollapseViz a
forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a
forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
forall a b.
NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b
forall a b c.
(a -> b -> c)
-> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> NullCollapseViz a
pure :: forall a. a -> NullCollapseViz a
$c<*> :: forall a b.
NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b
<*> :: forall a b.
NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c
liftA2 :: forall a b c.
(a -> b -> c)
-> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c
$c*> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
*> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
$c<* :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a
<* :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a
Applicative, Applicative NullCollapseViz
Applicative NullCollapseViz =>
(forall a b.
NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b)
-> (forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b)
-> (forall a. a -> NullCollapseViz a)
-> Monad NullCollapseViz
forall a. a -> NullCollapseViz a
forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
forall a b.
NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b
>>= :: forall a b.
NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b
$c>> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
>> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
$creturn :: forall a. a -> NullCollapseViz a
return :: forall a. a -> NullCollapseViz a
Monad, Monad NullCollapseViz
NullCollapseViz Unique
Monad NullCollapseViz =>
NullCollapseViz Unique -> MonadGetUnique NullCollapseViz
forall (m :: * -> *). Monad m => m Unique -> MonadGetUnique m
$cgetUniqueM :: NullCollapseViz Unique
getUniqueM :: NullCollapseViz Unique
MonadGetUnique)
instance MonadUniqDSM NullCollapseViz where
liftUniqDSM :: forall a. UniqDSM a -> NullCollapseViz a
liftUniqDSM = UniqDSM a -> NullCollapseViz a
forall a. UniqDSM a -> NullCollapseViz a
NullCollapseViz
instance (Graph gr, Supernode s NullCollapseViz) =>
VizCollapseMonad NullCollapseViz gr s where
consumeByInGraph :: Node -> Node -> gr s () -> NullCollapseViz ()
consumeByInGraph Node
_ Node
_ gr s ()
_ = () -> NullCollapseViz ()
forall a. a -> NullCollapseViz a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
splitGraphAt :: gr s () -> LNode s -> NullCollapseViz ()
splitGraphAt gr s ()
_ LNode s
_ = () -> NullCollapseViz ()
forall a. a -> NullCollapseViz a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
finalGraph :: gr s () -> NullCollapseViz ()
finalGraph gr s ()
_ = () -> NullCollapseViz ()
forall a. a -> NullCollapseViz a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runNullCollapse :: NullCollapseViz a -> UniqDSM a
runNullCollapse :: forall a. NullCollapseViz a -> UniqDSM a
runNullCollapse = NullCollapseViz a -> UniqDSM a
forall a. NullCollapseViz a -> UniqDSM a
unNCV
singlePred :: Graph gr => gr a b -> Node -> Bool
singlePred :: forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Bool
singlePred gr a b
gr Node
n
| ([(b, Node)
_], Node
_, a
_, Adj b
_) <- gr a b -> Node -> (Adj b, Node, a, Adj b)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context gr a b
gr Node
n = Bool
True
| Bool
otherwise = Bool
False
forceMatch :: (Graph gr)
=> Node -> gr s b -> (Context s b, gr s b)
forceMatch :: forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
node gr s b
g = case Node -> gr s b -> Decomp gr s b
forall a b. Node -> gr a b -> Decomp gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
node gr s b
g of (Just Context s b
c, gr s b
g') -> (Context s b
c, gr s b
g')
Decomp gr s b
_ -> Node -> gr s b -> (Context s b, gr s b)
forall (gr :: * -> * -> *) s b any.
Graph gr =>
Node -> gr s b -> any
panicDump Node
node gr s b
g
where panicDump :: Graph gr => Node -> gr s b -> any
panicDump :: forall (gr :: * -> * -> *) s b any.
Graph gr =>
Node -> gr s b -> any
panicDump Node
k gr s b
_g =
String -> any
forall a. HasCallStack => String -> a
panic (String -> any) -> String -> any
forall a b. (a -> b) -> a -> b
$ String
"GHC.Data.Graph.Collapse failed to match node " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
k
updateNode :: DynGraph gr => (s -> s) -> Node -> gr s b -> gr s b
updateNode :: forall (gr :: * -> * -> *) s b.
DynGraph gr =>
(s -> s) -> Node -> gr s b -> gr s b
updateNode s -> s
relabel Node
node gr s b
g = (Adj b
preds, Node
n, s -> s
relabel s
this, Adj b
succs) Context s b -> gr s b -> gr s b
forall a b. Context a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr s b
g'
where ((Adj b
preds, Node
n, s
this, Adj b
succs), gr s b
g') = Node -> gr s b -> (Context s b, gr s b)
forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
node gr s b
g
singletonGraph :: Graph gr => gr a b -> Bool
singletonGraph :: forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
singletonGraph gr a b
g = case gr a b -> [LNode a]
forall a b. gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr a b
g of [LNode a
_] -> Bool
True
[LNode a]
_ -> Bool
False
class (Semigroup node) => PureSupernode node where
superLabel :: node -> Label
mapLabels :: (Label -> Label) -> (node -> node)
class (MonadGetUnique m, PureSupernode node) => Supernode node m where
freshen :: node -> m node
consumeBy :: (DynGraph gr, PureSupernode s)
=> Node -> Node -> gr s () -> (gr s (), [Node])
consumeBy :: forall (gr :: * -> * -> *) s.
(DynGraph gr, PureSupernode s) =>
Node -> Node -> gr s () -> (gr s (), [Node])
consumeBy Node
toNode Node
fromNode gr s ()
g =
Bool -> (gr s (), [Node]) -> (gr s (), [Node])
forall a. HasCallStack => Bool -> a -> a
assert (Adj ()
toPreds Adj () -> Adj () -> Bool
forall a. Eq a => a -> a -> Bool
== [((), Node
fromNode)]) ((gr s (), [Node]) -> (gr s (), [Node]))
-> (gr s (), [Node]) -> (gr s (), [Node])
forall a b. (a -> b) -> a -> b
$
(gr s ()
newGraph, [Node]
newCandidates)
where ((Adj ()
toPreds, Node
_, s
to, Adj ()
toSuccs), gr s ()
g') = Node -> gr s () -> (Context s (), gr s ())
forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
toNode gr s ()
g
((Adj ()
fromPreds, Node
_, s
from, Adj ()
fromSuccs), gr s ()
g'') = Node -> gr s () -> (Context s (), gr s ())
forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
fromNode gr s ()
g'
context :: Context s ()
context = ( Adj ()
fromPreds
, Node
fromNode
, s
from s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
to
, ((), Node) -> Adj () -> Adj ()
forall a. Eq a => a -> [a] -> [a]
delete ((), Node
fromNode) Adj ()
toSuccs Adj () -> Adj () -> Adj ()
forall a. Eq a => [a] -> [a] -> [a]
`union` Adj ()
fromSuccs
)
newGraph :: gr s ()
newGraph = Context s ()
context Context s () -> gr s () -> gr s ()
forall a b. Context a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr s ()
g''
newCandidates :: [Node]
newCandidates = (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (gr s () -> Node -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Bool
singlePred gr s ()
newGraph) [Node]
changedNodes
changedNodes :: [Node]
changedNodes = Node
fromNode Node -> [Node] -> [Node]
forall a. Ord a => a -> [a] -> [a]
`insert` (((), Node) -> Node) -> Adj () -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map ((), Node) -> Node
forall a b. (a, b) -> b
snd (Adj ()
toSuccs Adj () -> Adj () -> Adj ()
forall a. Eq a => [a] -> [a] -> [a]
`intersect` Adj ()
fromSuccs)
split :: forall gr s b m . (DynGraph gr, Supernode s m)
=> Node -> gr s b -> m (gr s b)
split :: forall (gr :: * -> * -> *) s b (m :: * -> *).
(DynGraph gr, Supernode s m) =>
Node -> gr s b -> m (gr s b)
split Node
node gr s b
g = Bool -> m (gr s b) -> m (gr s b)
forall a. HasCallStack => Bool -> a -> a
assert ([(b, Node)] -> Bool
forall a. [a] -> Bool
isMultiple [(b, Node)]
preds) (m (gr s b) -> m (gr s b)) -> m (gr s b) -> m (gr s b)
forall a b. (a -> b) -> a -> b
$ (gr s b -> ((b, Node), Node) -> m (gr s b))
-> gr s b -> [((b, Node), Node)] -> m (gr s b)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM gr s b -> ((b, Node), Node) -> m (gr s b)
addReplica gr s b
g' [((b, Node), Node)]
newNodes
where (([(b, Node)]
preds, Node
_, s
this, [(b, Node)]
succs), gr s b
g') = Node -> gr s b -> (Context s b, gr s b)
forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
node gr s b
g
newNodes :: [((b, Node), Node)]
newNodes :: [((b, Node), Node)]
newNodes = [(b, Node)] -> [Node] -> [((b, Node), Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(b, Node)]
preds [Node
maxNodeNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1..]
(Node
_, Node
maxNode) = gr s b -> (Node, Node)
forall a b. gr a b -> (Node, Node)
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> (Node, Node)
nodeRange gr s b
g
thisLabel :: Label
thisLabel = s -> Label
forall node. PureSupernode node => node -> Label
superLabel s
this
addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b)
addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b)
addReplica gr s b
g ((b
b, Node
pred), Node
newNode) = do
newSuper <- s -> m s
forall node (m :: * -> *). Supernode node m => node -> m node
freshen s
this
return $ add newSuper
where add :: s -> gr s b
add s
newSuper =
(s -> s) -> Node -> gr s b -> gr s b
forall (gr :: * -> * -> *) s b.
DynGraph gr =>
(s -> s) -> Node -> gr s b -> gr s b
updateNode (Label
thisLabel Label -> Label -> s -> s
forall s. PureSupernode s => Label -> Label -> s -> s
`replacedWith` s -> Label
forall node. PureSupernode node => node -> Label
superLabel s
newSuper) Node
pred (gr s b -> gr s b) -> gr s b -> gr s b
forall a b. (a -> b) -> a -> b
$
([(b
b, Node
pred)], Node
newNode, s
newSuper, [(b, Node)]
succs) Context s b -> gr s b -> gr s b
forall a b. Context a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr s b
g
replacedWith :: PureSupernode s => Label -> Label -> s -> s
replacedWith :: forall s. PureSupernode s => Label -> Label -> s -> s
replacedWith Label
old Label
new = (Label -> Label) -> s -> s
forall node. PureSupernode node => (Label -> Label) -> node -> node
mapLabels (\Label
l -> if Label
l Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
old then Label
new else Label
l)
isMultiple :: [a] -> Bool
isMultiple :: forall a. [a] -> Bool
isMultiple [] = Bool
False
isMultiple [a
_] = Bool
False
isMultiple (a
_:a
_:[a]
_) = Bool
True
anySplittable :: forall gr a b . Graph gr => gr a b -> LNode a
anySplittable :: forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> LNode a
anySplittable gr a b
g = case [LNode a]
splittable of
LNode a
n : [LNode a]
_ -> LNode a
n
[] -> String -> LNode a
forall a. HasCallStack => String -> a
panic String
"anySplittable found no splittable nodes"
where splittable :: [LNode a]
splittable = (LNode a -> Bool) -> [LNode a] -> [LNode a]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Node] -> Bool
forall a. [a] -> Bool
isMultiple ([Node] -> Bool) -> (LNode a -> [Node]) -> LNode a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. gr a b -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
pre gr a b
g (Node -> [Node]) -> (LNode a -> Node) -> LNode a -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LNode a -> Node
forall a b. (a, b) -> a
fst) ([LNode a] -> [LNode a]) -> [LNode a] -> [LNode a]
forall a b. (a -> b) -> a -> b
$ gr a b -> [LNode a]
forall a b. gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr a b
g
splittable :: [LNode a]
collapseInductiveGraph :: (DynGraph gr, Supernode s m, VizCollapseMonad m gr s)
=> gr s () -> m (gr s ())
collapseInductiveGraph :: forall (gr :: * -> * -> *) s (m :: * -> *).
(DynGraph gr, Supernode s m, VizCollapseMonad m gr s) =>
gr s () -> m (gr s ())
collapseInductiveGraph gr s ()
g = gr s () -> [[Node]] -> m (gr s ())
forall {gr :: * -> * -> *} {m :: * -> *} {s}.
(VizCollapseMonad m gr s, DynGraph gr) =>
gr s () -> [[Node]] -> m (gr s ())
drain gr s ()
g [[Node]]
worklist
where worklist :: [[Node]]
worklist :: [[Node]]
worklist = [(Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (gr s () -> Node -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Bool
singlePred gr s ()
g) ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ gr s () -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes gr s ()
g]
drain :: gr s () -> [[Node]] -> m (gr s ())
drain gr s ()
g [] = if gr s () -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
singletonGraph gr s ()
g then gr s () -> m ()
forall (m :: * -> *) (gr :: * -> * -> *) s.
VizCollapseMonad m gr s =>
gr s () -> m ()
finalGraph gr s ()
g m () -> m (gr s ()) -> m (gr s ())
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> gr s () -> m (gr s ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return gr s ()
g
else let (Node
n, s
super) = gr s () -> (Node, s)
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> LNode a
anySplittable gr s ()
g
in do gr s () -> (Node, s) -> m ()
forall (m :: * -> *) (gr :: * -> * -> *) s.
VizCollapseMonad m gr s =>
gr s () -> LNode s -> m ()
splitGraphAt gr s ()
g (Node
n, s
super)
gr s () -> m (gr s ())
forall (gr :: * -> * -> *) s (m :: * -> *).
(DynGraph gr, Supernode s m, VizCollapseMonad m gr s) =>
gr s () -> m (gr s ())
collapseInductiveGraph (gr s () -> m (gr s ())) -> m (gr s ()) -> m (gr s ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node -> gr s () -> m (gr s ())
forall (gr :: * -> * -> *) s b (m :: * -> *).
(DynGraph gr, Supernode s m) =>
Node -> gr s b -> m (gr s b)
split Node
n gr s ()
g
drain gr s ()
g ([]:[[Node]]
nss) = gr s () -> [[Node]] -> m (gr s ())
drain gr s ()
g [[Node]]
nss
drain gr s ()
g ((Node
n:[Node]
ns):[[Node]]
nss) = let (gr s ()
g', [Node]
ns') = Node -> Node -> gr s () -> (gr s (), [Node])
forall (gr :: * -> * -> *) s.
(DynGraph gr, PureSupernode s) =>
Node -> Node -> gr s () -> (gr s (), [Node])
consumeBy Node
n (Node -> Node
theUniquePred Node
n) gr s ()
g
in do Node -> Node -> gr s () -> m ()
forall (m :: * -> *) (gr :: * -> * -> *) s.
VizCollapseMonad m gr s =>
Node -> Node -> gr s () -> m ()
consumeByInGraph Node
n (Node -> Node
theUniquePred Node
n) gr s ()
g
gr s () -> [[Node]] -> m (gr s ())
drain gr s ()
g' ([Node]
ns'[Node] -> [[Node]] -> [[Node]]
forall a. a -> [a] -> [a]
:[Node]
ns[Node] -> [[Node]] -> [[Node]]
forall a. a -> [a] -> [a]
:[[Node]]
nss)
where theUniquePred :: Node -> Node
theUniquePred Node
n
| ([(()
_, Node
p)], Node
_, s
_, Adj ()
_) <- gr s () -> Node -> (Adj (), Node, s, Adj ())
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context gr s ()
g Node
n = Node
p
| Bool
otherwise =
String -> Node
forall a. HasCallStack => String -> a
panic String
"node claimed to have a unique predecessor; it doesn't"