{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Data.Graph.Collapse
( PureSupernode(..)
, Supernode(..)
, collapseInductiveGraph
, VizCollapseMonad(..)
, NullCollapseViz(..)
, runNullCollapse
, MonadUniqSM(..)
)
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.Supply
import GHC.Utils.Panic
class (Monad m) => MonadUniqSM m where
liftUniqSM :: UniqSM a -> m a
class (MonadUniqSM 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 -> UniqSM a
unNCV :: UniqSM a }
deriving (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
<$ :: forall a b. a -> NullCollapseViz b -> NullCollapseViz a
$c<$ :: forall a b. a -> NullCollapseViz b -> NullCollapseViz a
fmap :: forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b
$cfmap :: forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b
Functor, Functor 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
<* :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a
$c<* :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a
*> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
$c*> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
liftA2 :: forall a b c.
(a -> b -> c)
-> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c
<*> :: forall a b.
NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b
$c<*> :: forall a b.
NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b
pure :: forall a. a -> NullCollapseViz a
$cpure :: forall a. a -> NullCollapseViz a
Applicative, Applicative 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
return :: forall a. a -> NullCollapseViz a
$creturn :: forall a. a -> NullCollapseViz a
>> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
$c>> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
>>= :: forall a b.
NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b
$c>>= :: forall a b.
NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b
Monad, Monad NullCollapseViz
NullCollapseViz [Unique]
NullCollapseViz UniqSupply
NullCollapseViz Unique
forall (m :: * -> *).
Monad m -> m UniqSupply -> m Unique -> m [Unique] -> MonadUnique m
getUniquesM :: NullCollapseViz [Unique]
$cgetUniquesM :: NullCollapseViz [Unique]
getUniqueM :: NullCollapseViz Unique
$cgetUniqueM :: NullCollapseViz Unique
getUniqueSupplyM :: NullCollapseViz UniqSupply
$cgetUniqueSupplyM :: NullCollapseViz UniqSupply
MonadUnique)
instance MonadUniqSM NullCollapseViz where
liftUniqSM :: forall a. UniqSM a -> NullCollapseViz a
liftUniqSM = forall a. UniqSM 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 ()
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
splitGraphAt :: gr s () -> LNode s -> NullCollapseViz ()
splitGraphAt gr s ()
_ LNode s
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
finalGraph :: gr s () -> NullCollapseViz ()
finalGraph gr s ()
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
runNullCollapse :: NullCollapseViz a -> UniqSM a
runNullCollapse :: forall a. NullCollapseViz a -> UniqSM a
runNullCollapse = forall a. NullCollapseViz a -> UniqSM 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
_) <- 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 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')
(MContext 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 =
forall a. HasCallStack => String -> a
panic forall a b. (a -> b) -> a -> b
$ String
"GHC.Data.Graph.Collapse failed to match node " forall a. [a] -> [a] -> [a]
++ 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) 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') = 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 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 (MonadUnique 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 =
forall a. HasCallStack => Bool -> a -> a
assert (Adj ()
toPreds forall a. Eq a => a -> a -> Bool
== [((), Node
fromNode)]) forall a b. (a -> b) -> a -> b
$
(gr s ()
newGraph, [Node]
newCandidates)
where ((Adj ()
toPreds, Node
_, s
to, Adj ()
toSuccs), gr s ()
g') = 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'') = 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 forall a. Semigroup a => a -> a -> a
<> s
to
, forall a. Eq a => a -> [a] -> [a]
delete ((), Node
fromNode) Adj ()
toSuccs forall a. Eq a => [a] -> [a] -> [a]
`union` Adj ()
fromSuccs
)
newGraph :: gr s ()
newGraph = Context s ()
context forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr s ()
g''
newCandidates :: [Node]
newCandidates = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Bool
singlePred gr s ()
newGraph) [Node]
changedNodes
changedNodes :: [Node]
changedNodes = Node
fromNode forall a. Ord a => a -> [a] -> [a]
`insert` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (Adj ()
toSuccs 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 = forall a. HasCallStack => Bool -> a -> a
assert (forall a. [a] -> Bool
isMultiple Adj b
preds) forall a b. (a -> b) -> a -> 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 ((Adj b
preds, Node
_, s
this, Adj b
succs), gr s b
g') = 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 = forall a b. [a] -> [b] -> [(a, b)]
zip Adj b
preds [Node
maxNodeforall a. Num a => a -> a -> a
+Node
1..]
(Node
_, Node
maxNode) = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> (Node, Node)
nodeRange gr s b
g
thisLabel :: Label
thisLabel = 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
s
newSuper <- forall node (m :: * -> *). Supernode node m => node -> m node
freshen s
this
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ s -> gr s b
add s
newSuper
where add :: s -> gr s b
add s
newSuper =
forall (gr :: * -> * -> *) s b.
DynGraph gr =>
(s -> s) -> Node -> gr s b -> gr s b
updateNode (Label
thisLabel forall s. PureSupernode s => Label -> Label -> s -> s
`replacedWith` forall node. PureSupernode node => node -> Label
superLabel s
newSuper) Node
pred forall a b. (a -> b) -> a -> b
$
([(b
b, Node
pred)], Node
newNode, s
newSuper, Adj b
succs) 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 = forall node. PureSupernode node => (Label -> Label) -> node -> node
mapLabels (\Label
l -> if Label
l 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
[] -> forall a. HasCallStack => String -> a
panic String
"anySplittable found no splittable nodes"
where splittable :: [LNode a]
splittable = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. [a] -> Bool
isMultiple forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
pre gr a b
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ 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 = 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 = [forall a. (a -> Bool) -> [a] -> [a]
filter (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Bool
singlePred gr s ()
g) forall a b. (a -> b) -> a -> b
$ 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 forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
singletonGraph gr s ()
g then forall (m :: * -> *) (gr :: * -> * -> *) s.
VizCollapseMonad m gr s =>
gr s () -> m ()
finalGraph gr s ()
g forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return gr s ()
g
else let (Node
n, s
super) = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> LNode a
anySplittable gr s ()
g
in do forall (m :: * -> *) (gr :: * -> * -> *) s.
VizCollapseMonad m gr s =>
gr s () -> LNode s -> m ()
splitGraphAt gr s ()
g (Node
n, s
super)
forall (gr :: * -> * -> *) s (m :: * -> *).
(DynGraph gr, Supernode s m, VizCollapseMonad m gr s) =>
gr s () -> m (gr s ())
collapseInductiveGraph forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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') = 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 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'forall a. a -> [a] -> [a]
:[Node]
nsforall a. a -> [a] -> [a]
:[[Node]]
nss)
where theUniquePred :: Node -> Node
theUniquePred Node
n
| ([(()
_, Node
p)], 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 =
forall a. HasCallStack => String -> a
panic String
"node claimed to have a unique predecessor; it doesn't"