{-# LANGUAGE RecordWildCards #-}
module Parsley.Internal.Frontend.Dependencies (dependencyAnalysis) where
import Control.Arrow (first, second)
import Control.Monad (unless, forM_)
import Data.Array (Array, (!), listArray)
import Data.Array.MArray (readArray, writeArray, newArray)
import Data.Array.ST (runSTUArray)
import Data.Array.Unboxed (assocs)
import Data.Dependent.Map (DMap)
import Data.List (foldl', partition, sortOn)
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Set (Set, insert, (\\), union, notMember, empty)
import Data.STRef (newSTRef, readSTRef, writeSTRef)
import Parsley.Internal.Common.Indexed (Fix, cata, Const1(..), (:*:)(..), zipper)
import Parsley.Internal.Common.State (State, MonadState, execState, modify')
import Parsley.Internal.Core.CombinatorAST (Combinator(..), traverseCombinator)
import Parsley.Internal.Core.Identifiers (IMVar, MVar(..), IΣVar, ΣVar(..))
import qualified Data.Dependent.Map as DMap (foldrWithKey, filterWithKey)
import qualified Data.Map.Strict as Map ((!), empty, insert, mapMaybeWithKey, findMax, elems, lookup, foldMapWithKey)
import qualified Data.Set as Set (elems, empty, insert, lookupMax)
type Graph = Array IMVar [IMVar]
dependencyAnalysis :: Fix Combinator a -> DMap MVar (Fix Combinator) -> (DMap MVar (Fix Combinator), Map IMVar (Set IΣVar), IΣVar)
dependencyAnalysis :: Fix Combinator a
-> DMap MVar (Fix Combinator)
-> (DMap MVar (Fix Combinator), Map IMVar (Set IΣVar), IΣVar)
dependencyAnalysis Fix Combinator a
toplevel DMap MVar (Fix Combinator)
μs =
let
roots :: Set IMVar
roots = Fix Combinator a -> Set IMVar
forall a. Fix Combinator a -> Set IMVar
directDependencies Fix Combinator a
toplevel
DependencyMaps{Map IMVar (Set IΣVar)
Map IMVar (Set IMVar)
definedRegisters :: DependencyMaps -> Map IMVar (Set IΣVar)
immediateDependencies :: DependencyMaps -> Map IMVar (Set IMVar)
usedRegisters :: DependencyMaps -> Map IMVar (Set IΣVar)
definedRegisters :: Map IMVar (Set IΣVar)
immediateDependencies :: Map IMVar (Set IMVar)
usedRegisters :: Map IMVar (Set IΣVar)
..} = DMap MVar (Fix Combinator) -> DependencyMaps
buildDependencyMaps DMap MVar (Fix Combinator)
μs
n :: IMVar
n = (IMVar, Set IMVar) -> IMVar
forall a b. (a, b) -> a
fst (Map IMVar (Set IMVar) -> (IMVar, Set IMVar)
forall k a. Map k a -> (k, a)
Map.findMax Map IMVar (Set IMVar)
immediateDependencies)
graph :: Graph
graph = IMVar -> Map IMVar (Set IMVar) -> Graph
buildGraph IMVar
n Map IMVar (Set IMVar)
immediateDependencies
([IMVar]
topo, Set IMVar
dead) = Set IMVar -> IMVar -> Graph -> ([IMVar], Set IMVar)
topoOrdering Set IMVar
roots IMVar
n Graph
graph
trueDeps :: Map IMVar (Set IMVar)
trueDeps = [IMVar] -> (IMVar, IMVar) -> Graph -> Map IMVar (Set IMVar)
flattenDependencies [IMVar]
topo ([IMVar] -> (IMVar, IMVar)
forall a. Ord a => [a] -> (a, a)
minMax [IMVar]
topo) Graph
graph
addNewRegs :: IMVar -> Set IΣVar -> Maybe (Set IΣVar)
addNewRegs IMVar
v Set IΣVar
uses
| IMVar -> Set IMVar -> Bool
forall a. Ord a => a -> Set a -> Bool
notMember IMVar
v Set IMVar
dead = let deps :: Set IMVar
deps = Map IMVar (Set IMVar)
trueDeps Map IMVar (Set IMVar) -> IMVar -> Set IMVar
forall k a. Ord k => Map k a -> k -> a
Map.! IMVar
v
defs :: Set IΣVar
defs = Map IMVar (Set IΣVar)
definedRegisters Map IMVar (Set IΣVar) -> IMVar -> Set IΣVar
forall k a. Ord k => Map k a -> k -> a
Map.! IMVar
v
subUses :: Set IΣVar
subUses = (IMVar -> Set IΣVar) -> Set IMVar -> Set IΣVar
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Map IMVar (Set IΣVar)
usedRegisters Map IMVar (Set IΣVar) -> IMVar -> Set IΣVar
forall k a. Ord k => Map k a -> k -> a
Map.!) Set IMVar
deps
subDefs :: Set IΣVar
subDefs = (IMVar -> Set IΣVar) -> Set IMVar -> Set IΣVar
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Map IMVar (Set IΣVar)
definedRegisters Map IMVar (Set IΣVar) -> IMVar -> Set IΣVar
forall k a. Ord k => Map k a -> k -> a
Map.!) Set IMVar
deps
in Set IΣVar -> Maybe (Set IΣVar)
forall a. a -> Maybe a
Just (Set IΣVar -> Maybe (Set IΣVar)) -> Set IΣVar -> Maybe (Set IΣVar)
forall a b. (a -> b) -> a -> b
$ (Set IΣVar
uses Set IΣVar -> Set IΣVar -> Set IΣVar
forall a. Ord a => Set a -> Set a -> Set a
\\ Set IΣVar
defs) Set IΣVar -> Set IΣVar -> Set IΣVar
forall a. Ord a => Set a -> Set a -> Set a
`union` (Set IΣVar
subUses Set IΣVar -> Set IΣVar -> Set IΣVar
forall a. Ord a => Set a -> Set a -> Set a
\\ Set IΣVar
subDefs)
| Bool
otherwise = Maybe (Set IΣVar)
forall a. Maybe a
Nothing
trueRegs :: Map IMVar (Set IΣVar)
trueRegs = (IMVar -> Set IΣVar -> Maybe (Set IΣVar))
-> Map IMVar (Set IΣVar) -> Map IMVar (Set IΣVar)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey IMVar -> Set IΣVar -> Maybe (Set IΣVar)
addNewRegs Map IMVar (Set IΣVar)
usedRegisters
largestRegister :: IΣVar
largestRegister = IΣVar -> Maybe IΣVar -> IΣVar
forall a. a -> Maybe a -> a
fromMaybe (-IΣVar
1) (Set IΣVar -> Maybe IΣVar
forall a. Set a -> Maybe a
Set.lookupMax ((IMVar -> Set IΣVar -> Set IΣVar)
-> Map IMVar (Set IΣVar) -> Set IΣVar
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey ((Set IΣVar -> Set IΣVar) -> IMVar -> Set IΣVar -> Set IΣVar
forall a b. a -> b -> a
const Set IΣVar -> Set IΣVar
forall a. a -> a
id) Map IMVar (Set IΣVar)
definedRegisters))
in ((forall v. MVar v -> Fix Combinator v -> Bool)
-> DMap MVar (Fix Combinator) -> DMap MVar (Fix Combinator)
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> Bool) -> DMap k2 f -> DMap k2 f
DMap.filterWithKey (\(MVar v) Fix Combinator v
_ -> IMVar -> Set IMVar -> Bool
forall a. Ord a => a -> Set a -> Bool
notMember IMVar
v Set IMVar
dead) DMap MVar (Fix Combinator)
μs, Map IMVar (Set IΣVar)
trueRegs, IΣVar
largestRegister)
minMax :: Ord a => [a] -> (a, a)
minMax :: [a] -> (a, a)
minMax [] = [Char] -> (a, a)
forall a. HasCallStack => [Char] -> a
error [Char]
"cannot find minimum or maximum of empty list"
minMax (a
x:[a]
xs) = ((a, a) -> a -> (a, a)) -> (a, a) -> [a] -> (a, a)
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(a
small, a
big) a
x -> (a -> a -> a
forall a. Ord a => a -> a -> a
min a
small a
x, a -> a -> a
forall a. Ord a => a -> a -> a
max a
big a
x)) (a
x, a
x) [a]
xs
buildGraph :: IMVar -> Map IMVar (Set IMVar) -> Graph
buildGraph :: IMVar -> Map IMVar (Set IMVar) -> Graph
buildGraph IMVar
n = (IMVar, IMVar) -> [[IMVar]] -> Graph
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (IMVar
0, IMVar
n) ([[IMVar]] -> Graph)
-> (Map IMVar (Set IMVar) -> [[IMVar]])
-> Map IMVar (Set IMVar)
-> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set IMVar -> [IMVar]) -> [Set IMVar] -> [[IMVar]]
forall a b. (a -> b) -> [a] -> [b]
map Set IMVar -> [IMVar]
forall a. Set a -> [a]
Set.elems ([Set IMVar] -> [[IMVar]])
-> (Map IMVar (Set IMVar) -> [Set IMVar])
-> Map IMVar (Set IMVar)
-> [[IMVar]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map IMVar (Set IMVar) -> [Set IMVar]
forall k a. Map k a -> [a]
Map.elems
topoOrdering :: Set IMVar -> IMVar -> Graph -> ([IMVar], Set IMVar)
topoOrdering :: Set IMVar -> IMVar -> Graph -> ([IMVar], Set IMVar)
topoOrdering Set IMVar
roots IMVar
n Graph
graph =
let dfnums :: UArray IMVar Int
dfnums = (forall s. ST s (STUArray s IMVar Int)) -> UArray IMVar Int
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray ((forall s. ST s (STUArray s IMVar Int)) -> UArray IMVar Int)
-> (forall s. ST s (STUArray s IMVar Int)) -> UArray IMVar Int
forall a b. (a -> b) -> a -> b
$ do
STUArray s IMVar Int
dfnums <- (IMVar, IMVar) -> Int -> ST s (STUArray s IMVar Int)
forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (IMVar
0, IMVar
n) (Int
0 :: Int)
STRef s Int
nextDfnum <- Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
1
let hasSeen :: IMVar -> ST s Bool
hasSeen IMVar
v = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (Int -> Bool) -> ST s Int -> ST s Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> STUArray s IMVar Int -> IMVar -> ST s Int
forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s IMVar Int
dfnums IMVar
v
let setSeen :: IMVar -> ST s ()
setSeen IMVar
v = do Int
dfnum <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
nextDfnum
STUArray s IMVar Int -> IMVar -> Int -> ST s ()
forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s IMVar Int
dfnums IMVar
v Int
dfnum
STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
nextDfnum (Int
dfnum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Set IMVar -> (IMVar -> ST s ()) -> ST s ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set IMVar
roots ((IMVar -> ST s Bool)
-> (IMVar -> ST s ()) -> Graph -> IMVar -> ST s ()
forall (m :: Type -> Type).
Monad m =>
(IMVar -> m Bool) -> (IMVar -> m ()) -> Graph -> IMVar -> m ()
dfs IMVar -> ST s Bool
hasSeen IMVar -> ST s ()
setSeen Graph
graph)
STUArray s IMVar Int -> ST s (STUArray s IMVar Int)
forall (m :: Type -> Type) a. Monad m => a -> m a
return STUArray s IMVar Int
dfnums
([(IMVar, Int)]
lives, [(IMVar, Int)]
deads) = ((IMVar, Int) -> Bool)
-> [(IMVar, Int)] -> ([(IMVar, Int)], [(IMVar, Int)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (Int -> Bool) -> ((IMVar, Int) -> Int) -> (IMVar, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IMVar, Int) -> Int
forall a b. (a, b) -> b
snd) (UArray IMVar Int -> [(IMVar, Int)]
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs UArray IMVar Int
dfnums)
in (((IMVar, Int) -> IMVar) -> [(IMVar, Int)] -> [IMVar]
forall a b. (a -> b) -> [a] -> [b]
reverseMap (IMVar, Int) -> IMVar
forall a b. (a, b) -> a
fst (((IMVar, Int) -> Int) -> [(IMVar, Int)] -> [(IMVar, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (IMVar, Int) -> Int
forall a b. (a, b) -> b
snd [(IMVar, Int)]
lives), (Set IMVar -> (IMVar, Int) -> Set IMVar)
-> Set IMVar -> [(IMVar, Int)] -> Set IMVar
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set IMVar
ds (IMVar, Int)
v0 -> IMVar -> Set IMVar -> Set IMVar
forall a. Ord a => a -> Set a -> Set a
Set.insert ((IMVar, Int) -> IMVar
forall a b. (a, b) -> a
fst (IMVar, Int)
v0) Set IMVar
ds) Set IMVar
forall a. Set a
Set.empty [(IMVar, Int)]
deads)
reverseMap :: (a -> b) -> [a] -> [b]
reverseMap :: (a -> b) -> [a] -> [b]
reverseMap a -> b
f = ([b] -> a -> [b]) -> [b] -> [a] -> [b]
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[b]
xs a
x -> a -> b
f a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
xs) []
flattenDependencies :: [IMVar] -> (IMVar, IMVar) -> Graph -> Map IMVar (Set IMVar)
flattenDependencies :: [IMVar] -> (IMVar, IMVar) -> Graph -> Map IMVar (Set IMVar)
flattenDependencies [IMVar]
topo (IMVar, IMVar)
range Graph
graph = (Map IMVar (Set IMVar) -> IMVar -> Map IMVar (Set IMVar))
-> Map IMVar (Set IMVar) -> [IMVar] -> Map IMVar (Set IMVar)
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map IMVar (Set IMVar) -> IMVar -> Map IMVar (Set IMVar)
reachable Map IMVar (Set IMVar)
forall k a. Map k a
Map.empty [IMVar]
topo
where
reachable :: Map IMVar (Set IMVar) -> IMVar -> Map IMVar (Set IMVar)
reachable :: Map IMVar (Set IMVar) -> IMVar -> Map IMVar (Set IMVar)
reachable Map IMVar (Set IMVar)
deps IMVar
root =
let seen :: UArray IMVar Bool
seen = (forall s. ST s (STUArray s IMVar Bool)) -> UArray IMVar Bool
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray ((forall s. ST s (STUArray s IMVar Bool)) -> UArray IMVar Bool)
-> (forall s. ST s (STUArray s IMVar Bool)) -> UArray IMVar Bool
forall a b. (a -> b) -> a -> b
$ do
STUArray s IMVar Bool
seen <- (IMVar, IMVar) -> Bool -> ST s (STUArray s IMVar Bool)
forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (IMVar, IMVar)
range Bool
False
let setSeen :: IMVar -> ST s ()
setSeen IMVar
v = STUArray s IMVar Bool -> IMVar -> Bool -> ST s ()
forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s IMVar Bool
seen IMVar
v Bool
True
let seenOrSkip :: IMVar -> ST s Bool
seenOrSkip IMVar
v = case IMVar -> Map IMVar (Set IMVar) -> Maybe (Set IMVar)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup IMVar
v Map IMVar (Set IMVar)
deps of
Maybe (Set IMVar)
Nothing -> STUArray s IMVar Bool -> IMVar -> ST s Bool
forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s IMVar Bool
seen IMVar
v
Just Set IMVar
ds -> IMVar -> ST s ()
setSeen IMVar
v ST s () -> ST s () -> ST s ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Set IMVar -> (IMVar -> ST s ()) -> ST s ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set IMVar
ds IMVar -> ST s ()
setSeen ST s () -> ST s Bool -> ST s Bool
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Bool -> ST s Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
(IMVar -> ST s Bool)
-> (IMVar -> ST s ()) -> Graph -> IMVar -> ST s ()
forall (m :: Type -> Type).
Monad m =>
(IMVar -> m Bool) -> (IMVar -> m ()) -> Graph -> IMVar -> m ()
dfs IMVar -> ST s Bool
seenOrSkip IMVar -> ST s ()
setSeen Graph
graph IMVar
root
STUArray s IMVar Bool -> ST s (STUArray s IMVar Bool)
forall (m :: Type -> Type) a. Monad m => a -> m a
return STUArray s IMVar Bool
seen
ds :: Set IMVar
ds = (Set IMVar -> (IMVar, Bool) -> Set IMVar)
-> Set IMVar -> [(IMVar, Bool)] -> Set IMVar
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set IMVar
ds (IMVar
v, Bool
b) -> if Bool
b then IMVar -> Set IMVar -> Set IMVar
forall a. Ord a => a -> Set a -> Set a
Set.insert IMVar
v Set IMVar
ds else Set IMVar
ds) Set IMVar
forall a. Set a
Set.empty (UArray IMVar Bool -> [(IMVar, Bool)]
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs UArray IMVar Bool
seen)
in IMVar
-> Set IMVar -> Map IMVar (Set IMVar) -> Map IMVar (Set IMVar)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IMVar
root Set IMVar
ds Map IMVar (Set IMVar)
deps
dfs :: Monad m => (IMVar -> m Bool) -> (IMVar -> m ()) -> Graph -> IMVar -> m ()
dfs :: (IMVar -> m Bool) -> (IMVar -> m ()) -> Graph -> IMVar -> m ()
dfs IMVar -> m Bool
hasSeen IMVar -> m ()
setSeen Graph
graph = IMVar -> m ()
go
where
go :: IMVar -> m ()
go IMVar
v = do Bool
seen <- IMVar -> m Bool
hasSeen IMVar
v
Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless Bool
seen (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
do IMVar -> m ()
setSeen IMVar
v
[IMVar] -> (IMVar -> m ()) -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Graph
graph Graph -> IMVar -> [IMVar]
forall i e. Ix i => Array i e -> i -> e
! IMVar
v) IMVar -> m ()
go
data DependencyMaps = DependencyMaps {
DependencyMaps -> Map IMVar (Set IΣVar)
usedRegisters :: Map IMVar (Set IΣVar),
DependencyMaps -> Map IMVar (Set IMVar)
immediateDependencies :: Map IMVar (Set IMVar),
DependencyMaps -> Map IMVar (Set IΣVar)
definedRegisters :: Map IMVar (Set IΣVar)
}
buildDependencyMaps :: DMap MVar (Fix Combinator) -> DependencyMaps
buildDependencyMaps :: DMap MVar (Fix Combinator) -> DependencyMaps
buildDependencyMaps = (forall v.
MVar v -> Fix Combinator v -> DependencyMaps -> DependencyMaps)
-> DependencyMaps -> DMap MVar (Fix Combinator) -> DependencyMaps
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) b.
(forall (v :: k1). k2 v -> f v -> b -> b) -> b -> DMap k2 f -> b
DMap.foldrWithKey (\(MVar v) Fix Combinator v
p deps :: DependencyMaps
deps@DependencyMaps{..} ->
let (Set IΣVar
frs, Set IΣVar
defs, Set IMVar
ds) = IMVar -> Fix Combinator v -> (Set IΣVar, Set IΣVar, Set IMVar)
forall a.
IMVar -> Fix Combinator a -> (Set IΣVar, Set IΣVar, Set IMVar)
freeRegistersAndDependencies IMVar
v Fix Combinator v
p
in DependencyMaps
deps { usedRegisters :: Map IMVar (Set IΣVar)
usedRegisters = IMVar
-> Set IΣVar -> Map IMVar (Set IΣVar) -> Map IMVar (Set IΣVar)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IMVar
v Set IΣVar
frs Map IMVar (Set IΣVar)
usedRegisters
, immediateDependencies :: Map IMVar (Set IMVar)
immediateDependencies = IMVar
-> Set IMVar -> Map IMVar (Set IMVar) -> Map IMVar (Set IMVar)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IMVar
v Set IMVar
ds Map IMVar (Set IMVar)
immediateDependencies
, definedRegisters :: Map IMVar (Set IΣVar)
definedRegisters = IMVar
-> Set IΣVar -> Map IMVar (Set IΣVar) -> Map IMVar (Set IΣVar)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IMVar
v Set IΣVar
defs Map IMVar (Set IΣVar)
definedRegisters}) (Map IMVar (Set IΣVar)
-> Map IMVar (Set IMVar) -> Map IMVar (Set IΣVar) -> DependencyMaps
DependencyMaps Map IMVar (Set IΣVar)
forall k a. Map k a
Map.empty Map IMVar (Set IMVar)
forall k a. Map k a
Map.empty Map IMVar (Set IΣVar)
forall k a. Map k a
Map.empty)
freeRegistersAndDependencies :: IMVar -> Fix Combinator a -> (Set IΣVar, Set IΣVar, Set IMVar)
freeRegistersAndDependencies :: IMVar -> Fix Combinator a -> (Set IΣVar, Set IΣVar, Set IMVar)
freeRegistersAndDependencies IMVar
v Fix Combinator a
p =
let FreeRegisters a
frsm :*: Dependencies a
depsm = (forall j. Combinator FreeRegisters j -> FreeRegisters j)
-> (forall j. Combinator Dependencies j -> Dependencies j)
-> Fix Combinator a
-> (:*:) FreeRegisters Dependencies a
forall (f :: (Type -> Type) -> Type -> Type) (a :: Type -> Type)
(b :: Type -> Type) i.
IFunctor f =>
(forall j. f a j -> a j)
-> (forall j. f b j -> b j) -> Fix f i -> (:*:) a b i
zipper forall j. Combinator FreeRegisters j -> FreeRegisters j
freeRegistersAlg (Maybe IMVar -> Combinator Dependencies j -> Dependencies j
forall a.
Maybe IMVar -> Combinator Dependencies a -> Dependencies a
dependenciesAlg (IMVar -> Maybe IMVar
forall a. a -> Maybe a
Just IMVar
v)) Fix Combinator a
p
(Set IΣVar
frs, Set IΣVar
defs) = FreeRegisters a -> (Set IΣVar, Set IΣVar)
forall k (a :: k). FreeRegisters a -> (Set IΣVar, Set IΣVar)
runFreeRegisters FreeRegisters a
frsm
ds :: Set IMVar
ds = Dependencies a -> Set IMVar
forall k (a :: k). Dependencies a -> Set IMVar
runDependencies Dependencies a
depsm
in (Set IΣVar
frs, Set IΣVar
defs, Set IMVar
ds)
newtype Dependencies a = Dependencies { Dependencies a -> State (Set IMVar) ()
doDependencies :: State (Set IMVar) () }
runDependencies :: Dependencies a -> Set IMVar
runDependencies :: Dependencies a -> Set IMVar
runDependencies = (State (Set IMVar) () -> Set IMVar -> Set IMVar)
-> Set IMVar -> State (Set IMVar) () -> Set IMVar
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Set IMVar) () -> Set IMVar -> Set IMVar
forall s a. State s a -> s -> s
execState Set IMVar
forall a. Set a
empty(State (Set IMVar) () -> Set IMVar)
-> (Dependencies a -> State (Set IMVar) ())
-> Dependencies a
-> Set IMVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies a -> State (Set IMVar) ()
forall k (a :: k). Dependencies a -> State (Set IMVar) ()
doDependencies
directDependencies :: Fix Combinator a -> Set IMVar
directDependencies :: Fix Combinator a -> Set IMVar
directDependencies = Dependencies a -> Set IMVar
forall k (a :: k). Dependencies a -> Set IMVar
runDependencies (Dependencies a -> Set IMVar)
-> (Fix Combinator a -> Dependencies a)
-> Fix Combinator a
-> Set IMVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall j. Combinator Dependencies j -> Dependencies j)
-> Fix Combinator a -> Dependencies a
forall (f :: (Type -> Type) -> Type -> Type) (a :: Type -> Type) i.
IFunctor f =>
(forall j. f a j -> a j) -> Fix f i -> a i
cata (Maybe IMVar -> Combinator Dependencies j -> Dependencies j
forall a.
Maybe IMVar -> Combinator Dependencies a -> Dependencies a
dependenciesAlg Maybe IMVar
forall a. Maybe a
Nothing)
{-# INLINE dependenciesAlg #-}
dependenciesAlg :: Maybe IMVar -> Combinator Dependencies a -> Dependencies a
dependenciesAlg :: Maybe IMVar -> Combinator Dependencies a -> Dependencies a
dependenciesAlg (Just IMVar
v) (Let Bool
_ μ :: MVar a
μ@(MVar IMVar
u) Dependencies a
_) = State (Set IMVar) () -> Dependencies a
forall k (a :: k). State (Set IMVar) () -> Dependencies a
Dependencies (State (Set IMVar) () -> Dependencies a)
-> State (Set IMVar) () -> Dependencies a
forall a b. (a -> b) -> a -> b
$ do Bool -> State (Set IMVar) () -> State (Set IMVar) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (IMVar
u IMVar -> IMVar -> Bool
forall a. Eq a => a -> a -> Bool
== IMVar
v) (MVar a -> State (Set IMVar) ()
forall (m :: Type -> Type) a.
MonadState (Set IMVar) m =>
MVar a -> m ()
dependsOn MVar a
μ)
dependenciesAlg Maybe IMVar
Nothing (Let Bool
_ MVar a
μ Dependencies a
_) = State (Set IMVar) () -> Dependencies a
forall k (a :: k). State (Set IMVar) () -> Dependencies a
Dependencies (State (Set IMVar) () -> Dependencies a)
-> State (Set IMVar) () -> Dependencies a
forall a b. (a -> b) -> a -> b
$ do MVar a -> State (Set IMVar) ()
forall (m :: Type -> Type) a.
MonadState (Set IMVar) m =>
MVar a -> m ()
dependsOn MVar a
μ
dependenciesAlg Maybe IMVar
_ Combinator Dependencies a
p = State (Set IMVar) () -> Dependencies a
forall k (a :: k). State (Set IMVar) () -> Dependencies a
Dependencies (State (Set IMVar) () -> Dependencies a)
-> State (Set IMVar) () -> Dependencies a
forall a b. (a -> b) -> a -> b
$ do (forall a1.
Dependencies a1 -> StateT (Set IMVar) Identity (Const1 () a1))
-> Combinator Dependencies a
-> StateT (Set IMVar) Identity (Combinator (Const1 ()) a)
forall (m :: Type -> Type) (f :: Type -> Type) (k :: Type -> Type)
a.
Applicative m =>
(forall a1. f a1 -> m (k a1))
-> Combinator f a -> m (Combinator k a)
traverseCombinator ((() -> Const1 () a1)
-> State (Set IMVar) ()
-> StateT (Set IMVar) Identity (Const1 () a1)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Const1 () a1
forall k a (k :: k). a -> Const1 a k
Const1 (State (Set IMVar) ()
-> StateT (Set IMVar) Identity (Const1 () a1))
-> (Dependencies a1 -> State (Set IMVar) ())
-> Dependencies a1
-> StateT (Set IMVar) Identity (Const1 () a1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies a1 -> State (Set IMVar) ()
forall k (a :: k). Dependencies a -> State (Set IMVar) ()
doDependencies) Combinator Dependencies a
p; () -> State (Set IMVar) ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
dependsOn :: MonadState (Set IMVar) m => MVar a -> m ()
dependsOn :: MVar a -> m ()
dependsOn (MVar IMVar
v) = (Set IMVar -> Set IMVar) -> m ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (IMVar -> Set IMVar -> Set IMVar
forall a. Ord a => a -> Set a -> Set a
insert IMVar
v)
newtype FreeRegisters a = FreeRegisters { FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
doFreeRegisters :: State (Set IΣVar, Set IΣVar) () }
runFreeRegisters :: FreeRegisters a -> (Set IΣVar, Set IΣVar)
runFreeRegisters :: FreeRegisters a -> (Set IΣVar, Set IΣVar)
runFreeRegisters = (State (Set IΣVar, Set IΣVar) ()
-> (Set IΣVar, Set IΣVar) -> (Set IΣVar, Set IΣVar))
-> (Set IΣVar, Set IΣVar)
-> State (Set IΣVar, Set IΣVar) ()
-> (Set IΣVar, Set IΣVar)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Set IΣVar, Set IΣVar) ()
-> (Set IΣVar, Set IΣVar) -> (Set IΣVar, Set IΣVar)
forall s a. State s a -> s -> s
execState (Set IΣVar
forall a. Set a
empty, Set IΣVar
forall a. Set a
empty) (State (Set IΣVar, Set IΣVar) () -> (Set IΣVar, Set IΣVar))
-> (FreeRegisters a -> State (Set IΣVar, Set IΣVar) ())
-> FreeRegisters a
-> (Set IΣVar, Set IΣVar)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
forall k (a :: k).
FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
doFreeRegisters
{-# INLINE freeRegistersAlg #-}
freeRegistersAlg :: Combinator FreeRegisters a -> FreeRegisters a
freeRegistersAlg :: Combinator FreeRegisters a -> FreeRegisters a
freeRegistersAlg (GetRegister ΣVar a
σ) = State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
FreeRegisters (State (Set IΣVar, Set IΣVar) () -> FreeRegisters a)
-> State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do ΣVar a -> State (Set IΣVar, Set IΣVar) ()
forall vs (m :: Type -> Type) a.
MonadState (Set IΣVar, vs) m =>
ΣVar a -> m ()
uses ΣVar a
σ
freeRegistersAlg (PutRegister ΣVar a
σ FreeRegisters a
p) = State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
FreeRegisters (State (Set IΣVar, Set IΣVar) () -> FreeRegisters a)
-> State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do ΣVar a -> State (Set IΣVar, Set IΣVar) ()
forall vs (m :: Type -> Type) a.
MonadState (Set IΣVar, vs) m =>
ΣVar a -> m ()
uses ΣVar a
σ; FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
forall k (a :: k).
FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
doFreeRegisters FreeRegisters a
p
freeRegistersAlg (MakeRegister ΣVar a
σ FreeRegisters a
p FreeRegisters a
q) = State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
FreeRegisters (State (Set IΣVar, Set IΣVar) () -> FreeRegisters a)
-> State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do ΣVar a -> State (Set IΣVar, Set IΣVar) ()
forall vs (m :: Type -> Type) a.
MonadState (vs, Set IΣVar) m =>
ΣVar a -> m ()
defs ΣVar a
σ; FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
forall k (a :: k).
FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
doFreeRegisters FreeRegisters a
p; FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
forall k (a :: k).
FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
doFreeRegisters FreeRegisters a
q
freeRegistersAlg Let{} = State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
FreeRegisters (State (Set IΣVar, Set IΣVar) () -> FreeRegisters a)
-> State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do () -> State (Set IΣVar, Set IΣVar) ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
freeRegistersAlg Combinator FreeRegisters a
p = State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
FreeRegisters (State (Set IΣVar, Set IΣVar) () -> FreeRegisters a)
-> State (Set IΣVar, Set IΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do (forall a1.
FreeRegisters a1
-> StateT (Set IΣVar, Set IΣVar) Identity (Const1 () a1))
-> Combinator FreeRegisters a
-> StateT
(Set IΣVar, Set IΣVar) Identity (Combinator (Const1 ()) a)
forall (m :: Type -> Type) (f :: Type -> Type) (k :: Type -> Type)
a.
Applicative m =>
(forall a1. f a1 -> m (k a1))
-> Combinator f a -> m (Combinator k a)
traverseCombinator ((() -> Const1 () a1)
-> State (Set IΣVar, Set IΣVar) ()
-> StateT (Set IΣVar, Set IΣVar) Identity (Const1 () a1)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Const1 () a1
forall k a (k :: k). a -> Const1 a k
Const1 (State (Set IΣVar, Set IΣVar) ()
-> StateT (Set IΣVar, Set IΣVar) Identity (Const1 () a1))
-> (FreeRegisters a1 -> State (Set IΣVar, Set IΣVar) ())
-> FreeRegisters a1
-> StateT (Set IΣVar, Set IΣVar) Identity (Const1 () a1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeRegisters a1 -> State (Set IΣVar, Set IΣVar) ()
forall k (a :: k).
FreeRegisters a -> State (Set IΣVar, Set IΣVar) ()
doFreeRegisters) Combinator FreeRegisters a
p; () -> State (Set IΣVar, Set IΣVar) ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
uses :: MonadState (Set IΣVar, vs) m => ΣVar a -> m ()
uses :: ΣVar a -> m ()
uses (ΣVar IΣVar
σ) = ((Set IΣVar, vs) -> (Set IΣVar, vs)) -> m ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' ((Set IΣVar -> Set IΣVar) -> (Set IΣVar, vs) -> (Set IΣVar, vs)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (IΣVar -> Set IΣVar -> Set IΣVar
forall a. Ord a => a -> Set a -> Set a
insert IΣVar
σ))
defs :: MonadState (vs, Set IΣVar) m => ΣVar a -> m ()
defs :: ΣVar a -> m ()
defs (ΣVar IΣVar
σ) = ((vs, Set IΣVar) -> (vs, Set IΣVar)) -> m ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' ((Set IΣVar -> Set IΣVar) -> (vs, Set IΣVar) -> (vs, Set IΣVar)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (IΣVar -> Set IΣVar -> Set IΣVar
forall a. Ord a => a -> Set a -> Set a
insert IΣVar
σ))