{-# LANGUAGE RecordWildCards #-}
{-|
Module      : Parsley.Internal.Frontend.Analysis.Dependencies
Description : Calculate dependencies of a collection of bindings.
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

Exposes `dependencyAnalysis`, which is used to calculate information
regarding the dependencies of each let-bound parser, as well as their
free-registers.

@since 1.5.0.0
-}
module Parsley.Internal.Frontend.Analysis.Dependencies (dependencyAnalysis) where

import Control.Monad                        (unless, forM_)
import Control.Monad.ST                     (ST)
import Data.Array                           (Array)
import Data.Array.MArray                    (readArray, writeArray, newArray, newArray_)
import Data.Array.ST                        (STArray, runSTUArray, runSTArray)
import Data.Array.Unboxed                   (UArray)
import Data.Bifunctor                       (first, second)
import Data.Dependent.Map                   (DMap)
import Data.Foldable                        (foldl')
import Data.Map.Strict                      (Map)
import Data.Set                             (Set)
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(..), ΣVar, SomeΣVar(..))

import qualified Data.Dependent.Map as DMap   (foldrWithKey, filterWithKey)
import qualified Data.Map.Strict    as Map    ((!), empty, insert, findMax, elems, maxView, fromList, fromDistinctAscList)
import qualified Data.Set           as Set    (toList, insert, union, unions, member, notMember, empty, (\\), fromDistinctAscList, size)
import qualified Data.Array         as Array  ((!), listArray, bounds, indices)
import qualified Data.Array.Unboxed as UArray ((!), assocs)
import qualified Data.List          as List   (partition)

type Graph = Array IMVar [IMVar]
type PQueue k a = Map k a

{-|
Given a top-level parser and a collection of its let-bound subjects performs the following tasks:

* Determines which parser depend on which others.
* Use the previous information to remove any dead bindings.
* Calculate the direct free registers for each binding.
* Propogate the free registers according to transitive need via the dependency graph.

Returns the non-dead bindings, the information about each bindings free registers, and the next
free index for any registers created in code generation.

@since 1.5.0.0
-}
-- TODO This actually should be in the backend... dead bindings and the topological ordering can be computed here
--      but the register stuff should come after register optimisation and instruction peephole
dependencyAnalysis :: Fix Combinator a -> DMap MVar (Fix Combinator) -> (DMap MVar (Fix Combinator), Map IMVar (Set SomeΣVar))
dependencyAnalysis :: forall a.
Fix Combinator a
-> DMap MVar (Fix Combinator)
-> (DMap MVar (Fix Combinator), Map IMVar (Set SomeΣVar))
dependencyAnalysis Fix Combinator a
toplevel DMap MVar (Fix Combinator)
μs =
  let -- Step 1: find roots of the toplevel
      roots :: Set IMVar
roots = forall a. Fix Combinator a -> Set IMVar
directDependencies Fix Combinator a
toplevel
      -- Step 2: build immediate dependencies
      DependencyMaps{Map IMVar (Set SomeΣVar)
Map IMVar (Set IMVar)
definedRegisters :: DependencyMaps -> Map IMVar (Set SomeΣVar)
immediateDependencies :: DependencyMaps -> Map IMVar (Set IMVar)
usedRegisters :: DependencyMaps -> Map IMVar (Set SomeΣVar)
definedRegisters :: Map IMVar (Set SomeΣVar)
immediateDependencies :: Map IMVar (Set IMVar)
usedRegisters :: Map IMVar (Set SomeΣVar)
..} = DMap MVar (Fix Combinator) -> DependencyMaps
buildDependencyMaps DMap MVar (Fix Combinator)
μs
      -- Step 3: Build a call graph
      callees :: Graph
callees = Map IMVar (Set IMVar) -> Graph
buildGraph Map IMVar (Set IMVar)
immediateDependencies
      -- Step 4: traverse the call graph, finding unreachable nodes and establishing a topological dfnum for each node
      (UArray IMVar DFNum
dfnums, [IMVar]
lives, Set IMVar
dead) = Set IMVar -> Graph -> (UArray IMVar DFNum, [IMVar], Set IMVar)
topoOrdering Set IMVar
roots Graph
callees
      -- Step 5: reverse the call graph to make a callers graph
      callers :: Graph
callers = Graph -> Set IMVar -> Graph
invertGraph Graph
callers Set IMVar
dead
      -- Step 6: iterate over the live registers, and propagate the free registers until fix-point
      regs :: Map IMVar (Set SomeΣVar)
regs = [IMVar]
-> UArray IMVar DFNum
-> Map IMVar (Set SomeΣVar)
-> Map IMVar (Set SomeΣVar)
-> Graph
-> Graph
-> Map IMVar (Set SomeΣVar)
propagateRegs [IMVar]
lives UArray IMVar DFNum
dfnums Map IMVar (Set SomeΣVar)
usedRegisters Map IMVar (Set SomeΣVar)
definedRegisters Graph
callees Graph
callers
  in (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 IMVar
v) Fix Combinator v
_ -> forall a. Ord a => a -> Set a -> Bool
Set.notMember IMVar
v Set IMVar
dead) DMap MVar (Fix Combinator)
μs, Map IMVar (Set SomeΣVar)
regs)

buildGraph :: Map IMVar (Set IMVar) -> Graph
buildGraph :: Map IMVar (Set IMVar) -> Graph
buildGraph Map IMVar (Set IMVar)
deps = forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (IMVar
0, forall a b. (a, b) -> a
fst (forall k a. Map k a -> (k, a)
Map.findMax Map IMVar (Set IMVar)
deps)) (forall a b. (a -> b) -> [a] -> [b]
map forall a. Set a -> [a]
Set.toList (forall k a. Map k a -> [a]
Map.elems Map IMVar (Set IMVar)
deps))

invertGraph :: Graph -> Set IMVar -> Graph
invertGraph :: Graph -> Set IMVar -> Graph
invertGraph Graph
g Set IMVar
unreachable = forall i e. (forall s. ST s (STArray s i e)) -> Array i e
runSTArray forall a b. (a -> b) -> a -> b
$ do
  STArray s IMVar [IMVar]
g' <- forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (forall i e. Array i e -> (i, i)
Array.bounds Graph
g) []
  forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall i e. Ix i => Array i e -> [i]
Array.indices Graph
g) forall a b. (a -> b) -> a -> b
$ \IMVar
n ->
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall a. Ord a => a -> Set a -> Bool
Set.member IMVar
n Set IMVar
unreachable) forall a b. (a -> b) -> a -> b
$
      forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Graph
g forall i e. Ix i => Array i e -> i -> e
Array.! IMVar
n) forall a b. (a -> b) -> a -> b
$ \IMVar
s -> do
        [IMVar]
preds <- forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s IMVar [IMVar]
g' IMVar
s
        forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s IMVar [IMVar]
g' IMVar
s (IMVar
n forall a. a -> [a] -> [a]
: [IMVar]
preds)
  forall (m :: Type -> Type) a. Monad m => a -> m a
return STArray s IMVar [IMVar]
g'

type DFNum = Int
topoOrdering :: Set IMVar -> Graph -> (UArray IMVar DFNum, [IMVar], Set IMVar)
topoOrdering :: Set IMVar -> Graph -> (UArray IMVar DFNum, [IMVar], Set IMVar)
topoOrdering Set IMVar
roots Graph
graph =
  let dfnums :: UArray IMVar DFNum
      dfnums :: UArray IMVar DFNum
dfnums = forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray forall a b. (a -> b) -> a -> b
$ do
        STUArray s IMVar DFNum
dfnums <- forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (forall i e. Array i e -> (i, i)
Array.bounds Graph
graph) DFNum
0
        STRef s DFNum
nextDfnum <- forall a s. a -> ST s (STRef s a)
newSTRef DFNum
1
        let dfs :: IMVar -> ST s ()
dfs IMVar
v = do Bool
seen <- (forall a. Eq a => a -> a -> Bool
/= DFNum
0) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 DFNum
dfnums IMVar
v
                       forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless Bool
seen forall a b. (a -> b) -> a -> b
$
                         do DFNum
dfnum <- forall s a. STRef s a -> ST s a
readSTRef STRef s DFNum
nextDfnum
                            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 DFNum
dfnums IMVar
v DFNum
dfnum
                            forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s DFNum
nextDfnum (DFNum
dfnum forall a. Num a => a -> a -> a
+ DFNum
1)
                            forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Graph
graph forall i e. Ix i => Array i e -> i -> e
Array.! IMVar
v) IMVar -> ST s ()
dfs
        -- Assign a DFNum to each IMVar
        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 ()
dfs
        forall (m :: Type -> Type) a. Monad m => a -> m a
return STUArray s IMVar DFNum
dfnums
      -- if something still has dfnum 0, it was not visited, and is dead
      lives, deads :: [(IMVar, DFNum)]
      ([(IMVar, DFNum)]
lives, [(IMVar, DFNum)]
deads) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((forall a. Eq a => a -> a -> Bool
/= DFNum
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
UArray.assocs UArray IMVar DFNum
dfnums)
      -- The DFNums are unique
  in (UArray IMVar DFNum
dfnums, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(IMVar, DFNum)]
lives, forall a. [a] -> Set a
Set.fromDistinctAscList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(IMVar, DFNum)]
deads))

propagateRegs :: [IMVar] -> UArray IMVar DFNum -> Map IMVar (Set SomeΣVar) -> Map IMVar (Set SomeΣVar) -> Graph -> Graph -> Map IMVar (Set SomeΣVar)
propagateRegs :: [IMVar]
-> UArray IMVar DFNum
-> Map IMVar (Set SomeΣVar)
-> Map IMVar (Set SomeΣVar)
-> Graph
-> Graph
-> Map IMVar (Set SomeΣVar)
propagateRegs [IMVar]
reachables UArray IMVar DFNum
dfnums Map IMVar (Set SomeΣVar)
uses Map IMVar (Set SomeΣVar)
defs Graph
callees Graph
callers = Array IMVar (Set SomeΣVar) -> Map IMVar (Set SomeΣVar)
toMap forall a b. (a -> b) -> a -> b
$ forall i e. (forall s. ST s (STArray s i e)) -> Array i e
runSTArray forall a b. (a -> b) -> a -> b
$
  do STArray s IMVar (Set SomeΣVar)
freeRegs <- forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (forall i e. Array i e -> (i, i)
Array.bounds Graph
callees)
     forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IMVar]
reachables forall a b. (a -> b) -> a -> b
$ \IMVar
v -> forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s IMVar (Set SomeΣVar)
freeRegs IMVar
v ((Map IMVar (Set SomeΣVar)
uses forall k a. Ord k => Map k a -> k -> a
Map.! IMVar
v) forall a. Ord a => Set a -> Set a -> Set a
Set.\\ (Map IMVar (Set SomeΣVar)
defs forall k a. Ord k => Map k a -> k -> a
Map.! IMVar
v))
     let worklist :: Map DFNum IMVar
worklist = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\IMVar
v -> (UArray IMVar DFNum
dfnums forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
UArray.! IMVar
v, IMVar
v)) [IMVar]
reachables)
     forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: Type -> Type) a. Monad m => a -> m a
return ()) (forall (m :: Type -> Type) s.
Monad m =>
(s -> m (Maybe s)) -> s -> m ()
unfoldM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall s.
STArray s IMVar (Set SomeΣVar)
-> IMVar
-> Map DFNum IMVar
-> ST s (Maybe (IMVar, Map DFNum IMVar))
propagate STArray s IMVar (Set SomeΣVar)
freeRegs))) (forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map DFNum IMVar
worklist)
     forall (m :: Type -> Type) a. Monad m => a -> m a
return STArray s IMVar (Set SomeΣVar)
freeRegs
  where
    propagate :: STArray s IMVar (Set SomeΣVar) -> IMVar -> PQueue DFNum IMVar -> ST s (Maybe (IMVar, PQueue DFNum IMVar))
    propagate :: forall s.
STArray s IMVar (Set SomeΣVar)
-> IMVar
-> Map DFNum IMVar
-> ST s (Maybe (IMVar, Map DFNum IMVar))
propagate STArray s IMVar (Set SomeΣVar)
freeRegs IMVar
v Map DFNum IMVar
work = do
      !Set SomeΣVar
frees        <- forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s IMVar (Set SomeΣVar)
freeRegs IMVar
v
      !Set SomeΣVar
freesCallees <- forall (f :: Type -> Type) a.
(Foldable f, Ord a) =>
f (Set a) -> Set a
Set.unions forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s IMVar (Set SomeΣVar)
freeRegs) (Graph
callees forall i e. Ix i => Array i e -> i -> e
Array.! IMVar
v)
      let !frees' :: Set SomeΣVar
frees'   =  Set SomeΣVar
frees forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (Set SomeΣVar
freesCallees forall a. Ord a => Set a -> Set a -> Set a
Set.\\ (Map IMVar (Set SomeΣVar)
defs forall k a. Ord k => Map k a -> k -> a
Map.! IMVar
v))
      if forall a. Set a -> DFNum
Set.size Set SomeΣVar
frees forall a. Eq a => a -> a -> Bool
/= forall a. Set a -> DFNum
Set.size Set SomeΣVar
frees' then do
        forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s IMVar (Set SomeΣVar)
freeRegs IMVar
v Set SomeΣVar
frees'
        forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView ([IMVar] -> Map DFNum IMVar -> Map DFNum IMVar
addWork (Graph
callers forall i e. Ix i => Array i e -> i -> e
Array.! IMVar
v) Map DFNum IMVar
work))
      else forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map DFNum IMVar
work)

    addWork :: [IMVar] -> PQueue DFNum IMVar -> PQueue DFNum IMVar
    addWork :: [IMVar] -> Map DFNum IMVar -> Map DFNum IMVar
addWork [IMVar]
vs Map DFNum IMVar
work = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (\IMVar
v -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UArray IMVar DFNum
dfnums forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
UArray.! IMVar
v) IMVar
v)) Map DFNum IMVar
work [IMVar]
vs

    unfoldM_ :: Monad m => (s -> m (Maybe s)) -> s -> m ()
    unfoldM_ :: forall (m :: Type -> Type) s.
Monad m =>
(s -> m (Maybe s)) -> s -> m ()
unfoldM_ s -> m (Maybe s)
f s
s = s -> m (Maybe s)
f s
s forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: Type -> Type) s.
Monad m =>
(s -> m (Maybe s)) -> s -> m ()
unfoldM_ s -> m (Maybe s)
f)

    toMap :: Array IMVar (Set SomeΣVar) -> Map IMVar (Set SomeΣVar)
toMap Array IMVar (Set SomeΣVar)
arr = forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList (forall a b. (a -> b) -> [a] -> [b]
map (\IMVar
v -> (IMVar
v, Array IMVar (Set SomeΣVar)
arr forall i e. Ix i => Array i e -> i -> e
Array.! IMVar
v)) [IMVar]
reachables)

-- IMMEDIATE DEPENDENCY MAPS
data DependencyMaps = DependencyMaps {
  DependencyMaps -> Map IMVar (Set SomeΣVar)
usedRegisters         :: !(Map IMVar (Set SomeΣVar)), -- Leave Lazy
  DependencyMaps -> Map IMVar (Set IMVar)
immediateDependencies :: !(Map IMVar (Set IMVar)), -- Could be Strict
  DependencyMaps -> Map IMVar (Set SomeΣVar)
definedRegisters      :: !(Map IMVar (Set SomeΣVar))
}

buildDependencyMaps :: DMap MVar (Fix Combinator) -> DependencyMaps
buildDependencyMaps :: DMap MVar (Fix Combinator) -> DependencyMaps
buildDependencyMaps = 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 IMVar
v) Fix Combinator v
p deps :: DependencyMaps
deps@DependencyMaps{Map IMVar (Set SomeΣVar)
Map IMVar (Set IMVar)
definedRegisters :: Map IMVar (Set SomeΣVar)
immediateDependencies :: Map IMVar (Set IMVar)
usedRegisters :: Map IMVar (Set SomeΣVar)
definedRegisters :: DependencyMaps -> Map IMVar (Set SomeΣVar)
immediateDependencies :: DependencyMaps -> Map IMVar (Set IMVar)
usedRegisters :: DependencyMaps -> Map IMVar (Set SomeΣVar)
..} ->
  let (Set SomeΣVar
uses, Set SomeΣVar
defs, Set IMVar
ds) = forall a.
IMVar
-> Fix Combinator a -> (Set SomeΣVar, Set SomeΣVar, Set IMVar)
freeRegistersAndDependencies IMVar
v Fix Combinator v
p
  in DependencyMaps
deps { usedRegisters :: Map IMVar (Set SomeΣVar)
usedRegisters = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IMVar
v Set SomeΣVar
uses Map IMVar (Set SomeΣVar)
usedRegisters
          , immediateDependencies :: Map IMVar (Set IMVar)
immediateDependencies = 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 SomeΣVar)
definedRegisters = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IMVar
v Set SomeΣVar
defs Map IMVar (Set SomeΣVar)
definedRegisters}) (Map IMVar (Set SomeΣVar)
-> Map IMVar (Set IMVar)
-> Map IMVar (Set SomeΣVar)
-> DependencyMaps
DependencyMaps forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty)

freeRegistersAndDependencies :: IMVar -> Fix Combinator a -> (Set SomeΣVar,  Set SomeΣVar, Set IMVar)
freeRegistersAndDependencies :: forall a.
IMVar
-> Fix Combinator a -> (Set SomeΣVar, Set SomeΣVar, Set IMVar)
freeRegistersAndDependencies IMVar
v Fix Combinator a
p =
  let FreeRegisters a
frsm :*: Dependencies a
depsm = 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 a. Combinator FreeRegisters a -> FreeRegisters a
freeRegistersAlg (forall a.
Maybe IMVar -> Combinator Dependencies a -> Dependencies a
dependenciesAlg (forall a. a -> Maybe a
Just IMVar
v)) Fix Combinator a
p
      (Set SomeΣVar
uses, Set SomeΣVar
defs) = forall {k} (a :: k).
FreeRegisters a -> (Set SomeΣVar, Set SomeΣVar)
runFreeRegisters FreeRegisters a
frsm
      ds :: Set IMVar
ds = forall {k} (a :: k). Dependencies a -> Set IMVar
runDependencies Dependencies a
depsm
  in (Set SomeΣVar
uses, Set SomeΣVar
defs, Set IMVar
ds)

-- DEPENDENCY ANALYSIS
newtype Dependencies a = Dependencies { forall {k} (a :: k). Dependencies a -> State (Set IMVar) ()
doDependencies :: State (Set IMVar) () }
runDependencies :: Dependencies a -> Set IMVar
runDependencies :: forall {k} (a :: k). Dependencies a -> Set IMVar
runDependencies = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState forall a. Set a
Set.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k). Dependencies a -> State (Set IMVar) ()
doDependencies

directDependencies :: Fix Combinator a -> Set IMVar
directDependencies :: forall a. Fix Combinator a -> Set IMVar
directDependencies = forall {k} (a :: k). Dependencies a -> Set IMVar
runDependencies forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall a.
Maybe IMVar -> Combinator Dependencies a -> Dependencies a
dependenciesAlg forall a. Maybe a
Nothing)

{-# INLINE dependenciesAlg #-}
dependenciesAlg :: Maybe IMVar -> Combinator Dependencies a -> Dependencies a
dependenciesAlg :: forall a.
Maybe IMVar -> Combinator Dependencies a -> Dependencies a
dependenciesAlg (Just IMVar
v) (Let μ :: MVar a
μ@(MVar IMVar
u)) = forall {k} (a :: k). State (Set IMVar) () -> Dependencies a
Dependencies forall a b. (a -> b) -> a -> b
$ do forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (IMVar
u forall a. Eq a => a -> a -> Bool
== IMVar
v) (forall (m :: Type -> Type) a.
MonadState (Set IMVar) m =>
MVar a -> m ()
dependsOn MVar a
μ)
dependenciesAlg Maybe IMVar
Nothing  (Let MVar a
μ)          = forall {k} (a :: k). State (Set IMVar) () -> Dependencies a
Dependencies forall a b. (a -> b) -> a -> b
$ do forall (m :: Type -> Type) a.
MonadState (Set IMVar) m =>
MVar a -> m ()
dependsOn MVar a
μ
dependenciesAlg Maybe IMVar
_ Combinator Dependencies a
p                       = forall {k} (a :: k). State (Set IMVar) () -> Dependencies a
Dependencies forall a b. (a -> b) -> a -> b
$ do 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 (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} a (k1 :: k). a -> Const1 a k1
Const1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k). Dependencies a -> State (Set IMVar) ()
doDependencies) Combinator Dependencies a
p; forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

dependsOn :: MonadState (Set IMVar) m => MVar a -> m ()
dependsOn :: forall (m :: Type -> Type) a.
MonadState (Set IMVar) m =>
MVar a -> m ()
dependsOn (MVar IMVar
v) = forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (forall a. Ord a => a -> Set a -> Set a
Set.insert IMVar
v)

-- FREE REGISTER ANALYSIS
newtype FreeRegisters a = FreeRegisters { forall {k} (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters :: State (Set SomeΣVar, Set SomeΣVar) () }
runFreeRegisters :: FreeRegisters a -> (Set SomeΣVar, Set SomeΣVar)
runFreeRegisters :: forall {k} (a :: k).
FreeRegisters a -> (Set SomeΣVar, Set SomeΣVar)
runFreeRegisters = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState (forall a. Set a
Set.empty, forall a. Set a
Set.empty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters

{-# INLINE freeRegistersAlg #-}
freeRegistersAlg :: Combinator FreeRegisters a -> FreeRegisters a
freeRegistersAlg :: forall a. Combinator FreeRegisters a -> FreeRegisters a
freeRegistersAlg (GetRegister ΣVar a
σ)      = forall {k} (a :: k).
State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
FreeRegisters forall a b. (a -> b) -> a -> b
$ do forall vs (m :: Type -> Type) a.
MonadState (Set SomeΣVar, vs) m =>
ΣVar a -> m ()
uses ΣVar a
σ
freeRegistersAlg (PutRegister ΣVar a1
σ FreeRegisters a1
p)    = forall {k} (a :: k).
State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
FreeRegisters forall a b. (a -> b) -> a -> b
$ do forall vs (m :: Type -> Type) a.
MonadState (Set SomeΣVar, vs) m =>
ΣVar a -> m ()
uses ΣVar a1
σ; forall {k} (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters FreeRegisters a1
p
freeRegistersAlg (MakeRegister ΣVar a1
σ FreeRegisters a1
p FreeRegisters a
q) = forall {k} (a :: k).
State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
FreeRegisters forall a b. (a -> b) -> a -> b
$ do forall vs (m :: Type -> Type) a.
MonadState (vs, Set SomeΣVar) m =>
ΣVar a -> m ()
defs ΣVar a1
σ; forall {k} (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters FreeRegisters a1
p; forall {k} (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters FreeRegisters a
q
freeRegistersAlg Combinator FreeRegisters a
p                    = forall {k} (a :: k).
State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
FreeRegisters forall a b. (a -> b) -> a -> b
$ do 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 (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} a (k1 :: k). a -> Const1 a k1
Const1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters) Combinator FreeRegisters a
p; forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

uses :: MonadState (Set SomeΣVar, vs) m => ΣVar a -> m ()
uses :: forall vs (m :: Type -> Type) a.
MonadState (Set SomeΣVar, vs) m =>
ΣVar a -> m ()
uses ΣVar a
σ = forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Ord a => a -> Set a -> Set a
Set.insert (forall r. ΣVar r -> SomeΣVar
SomeΣVar ΣVar a
σ)))

defs :: MonadState (vs, Set SomeΣVar) m => ΣVar a -> m ()
defs :: forall vs (m :: Type -> Type) a.
MonadState (vs, Set SomeΣVar) m =>
ΣVar a -> m ()
defs ΣVar a
σ = forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify' (forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Ord a => a -> Set a -> Set a
Set.insert (forall r. ΣVar r -> SomeΣVar
SomeΣVar ΣVar a
σ)))