{-# 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.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.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(..), ΣVar, SomeΣVar(..))

import qualified Data.Dependent.Map as DMap (foldrWithKey, filterWithKey)
import qualified Data.Map.Strict    as Map  ((!), empty, insert, mapMaybeWithKey, findMax, elems, lookup)
import qualified Data.Set           as Set  (elems, empty, insert)

type Graph = Array IMVar [IMVar]

{-|
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 :: 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 = Fix Combinator a -> Set IMVar
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: find the largest name
      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)
      -- Step 4: Build a dependency graph
      graph :: Graph
graph = IMVar -> Map IMVar (Set IMVar) -> Graph
buildGraph IMVar
n Map IMVar (Set IMVar)
immediateDependencies
      -- Step 5: construct the seen set (dfnum)
      -- Step 6: dfs from toplevel (via roots) all with same seen set
      -- Step 7: elems of seen set with dfnum 0 are dead, otherwise they are collected into a list in descending order
      ([IMVar]
topo, Set IMVar
dead) = Set IMVar -> IMVar -> Graph -> ([IMVar], Set IMVar)
topoOrdering Set IMVar
roots IMVar
n Graph
graph
      -- Step 8: perform a dfs on each of the topo, with a new seen set for each,
      --         building the flattened dependency map. If the current focus has
      --         already been computed, add all its deps to the seen set and skip.
      --         The end seen set becomes out flattened deps.
      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
      -- Step 8: Compute the new registers, and remove dead ones
      addNewRegs :: IMVar -> Set SomeΣVar -> Maybe (Set SomeΣVar)
addNewRegs IMVar
v Set SomeΣ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 SomeΣVar
defs = Map IMVar (Set SomeΣVar)
definedRegisters Map IMVar (Set SomeΣVar) -> IMVar -> Set SomeΣVar
forall k a. Ord k => Map k a -> k -> a
Map.! IMVar
v
                                 subUses :: Set SomeΣVar
subUses = (IMVar -> Set SomeΣVar) -> Set IMVar -> Set SomeΣVar
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Map IMVar (Set SomeΣVar)
usedRegisters Map IMVar (Set SomeΣVar) -> IMVar -> Set SomeΣVar
forall k a. Ord k => Map k a -> k -> a
Map.!) Set IMVar
deps
                                 subDefs :: Set SomeΣVar
subDefs = (IMVar -> Set SomeΣVar) -> Set IMVar -> Set SomeΣVar
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Map IMVar (Set SomeΣVar)
definedRegisters Map IMVar (Set SomeΣVar) -> IMVar -> Set SomeΣVar
forall k a. Ord k => Map k a -> k -> a
Map.!) Set IMVar
deps
                             in Set SomeΣVar -> Maybe (Set SomeΣVar)
forall a. a -> Maybe a
Just (Set SomeΣVar -> Maybe (Set SomeΣVar))
-> Set SomeΣVar -> Maybe (Set SomeΣVar)
forall a b. (a -> b) -> a -> b
$ (Set SomeΣVar
uses Set SomeΣVar -> Set SomeΣVar -> Set SomeΣVar
forall a. Ord a => Set a -> Set a -> Set a
\\ Set SomeΣVar
defs) Set SomeΣVar -> Set SomeΣVar -> Set SomeΣVar
forall a. Ord a => Set a -> Set a -> Set a
`union` (Set SomeΣVar
subUses Set SomeΣVar -> Set SomeΣVar -> Set SomeΣVar
forall a. Ord a => Set a -> Set a -> Set a
\\ Set SomeΣVar
subDefs)
        | Bool
otherwise        = Maybe (Set SomeΣVar)
forall a. Maybe a
Nothing
      trueRegs :: Map IMVar (Set SomeΣVar)
trueRegs = (IMVar -> Set SomeΣVar -> Maybe (Set SomeΣVar))
-> Map IMVar (Set SomeΣVar) -> Map IMVar (Set SomeΣVar)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey IMVar -> Set SomeΣVar -> Maybe (Set SomeΣVar)
addNewRegs Map IMVar (Set SomeΣVar)
usedRegisters
  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 SomeΣVar)
trueRegs)

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

-- 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 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 SomeΣVar
frs, Set SomeΣVar
defs, Set IMVar
ds) = IMVar
-> Fix Combinator v -> (Set SomeΣVar, Set SomeΣVar, Set IMVar)
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 = IMVar
-> Set SomeΣVar
-> Map IMVar (Set SomeΣVar)
-> Map IMVar (Set SomeΣVar)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert IMVar
v Set SomeΣVar
frs Map IMVar (Set SomeΣ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 SomeΣVar)
definedRegisters = IMVar
-> Set SomeΣVar
-> Map IMVar (Set SomeΣVar)
-> Map IMVar (Set SomeΣVar)
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 Map IMVar (Set SomeΣVar)
forall k a. Map k a
Map.empty Map IMVar (Set IMVar)
forall k a. Map k a
Map.empty Map IMVar (Set SomeΣVar)
forall k a. Map k a
Map.empty)

freeRegistersAndDependencies :: IMVar -> Fix Combinator a -> (Set SomeΣVar,  Set SomeΣVar, Set IMVar)
freeRegistersAndDependencies :: 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 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 SomeΣVar
frs, Set SomeΣVar
defs) = FreeRegisters a -> (Set SomeΣVar, Set SomeΣVar)
forall k (a :: k). FreeRegisters a -> (Set SomeΣVar, Set SomeΣ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 SomeΣVar
frs, Set SomeΣVar
defs, Set IMVar
ds)

-- DEPENDENCY ANALYSIS
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)) = 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
μ)          = 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)

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

{-# INLINE freeRegistersAlg #-}
freeRegistersAlg :: Combinator FreeRegisters a -> FreeRegisters a
freeRegistersAlg :: Combinator FreeRegisters a -> FreeRegisters a
freeRegistersAlg (GetRegister ΣVar a
σ)      = State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
FreeRegisters (State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a)
-> State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do ΣVar a -> State (Set SomeΣVar, Set SomeΣVar) ()
forall vs (m :: Type -> Type) a.
MonadState (Set SomeΣVar, vs) m =>
ΣVar a -> m ()
uses ΣVar a
σ
freeRegistersAlg (PutRegister ΣVar a
σ FreeRegisters a
p)    = State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
FreeRegisters (State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a)
-> State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do ΣVar a -> State (Set SomeΣVar, Set SomeΣVar) ()
forall vs (m :: Type -> Type) a.
MonadState (Set SomeΣVar, vs) m =>
ΣVar a -> m ()
uses ΣVar a
σ; FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
forall k (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters FreeRegisters a
p
freeRegistersAlg (MakeRegister ΣVar a
σ FreeRegisters a
p FreeRegisters a
q) = State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
FreeRegisters (State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a)
-> State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do ΣVar a -> State (Set SomeΣVar, Set SomeΣVar) ()
forall vs (m :: Type -> Type) a.
MonadState (vs, Set SomeΣVar) m =>
ΣVar a -> m ()
defs ΣVar a
σ; FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
forall k (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters FreeRegisters a
p; FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
forall k (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters FreeRegisters a
q
freeRegistersAlg Let{}                = State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
FreeRegisters (State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a)
-> State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do () -> State (Set SomeΣVar, Set SomeΣVar) ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return () -- TODO This can be removed when Let doesn't have the body in it...
freeRegistersAlg Combinator FreeRegisters a
p                    = State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall k (a :: k).
State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
FreeRegisters (State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a)
-> State (Set SomeΣVar, Set SomeΣVar) () -> FreeRegisters a
forall a b. (a -> b) -> a -> b
$ do (forall a1.
 FreeRegisters a1
 -> StateT (Set SomeΣVar, Set SomeΣVar) Identity (Const1 () a1))
-> Combinator FreeRegisters a
-> StateT
     (Set SomeΣVar, Set SomeΣ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 SomeΣVar, Set SomeΣVar) ()
-> StateT (Set SomeΣVar, Set SomeΣ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 SomeΣVar, Set SomeΣVar) ()
 -> StateT (Set SomeΣVar, Set SomeΣVar) Identity (Const1 () a1))
-> (FreeRegisters a1 -> State (Set SomeΣVar, Set SomeΣVar) ())
-> FreeRegisters a1
-> StateT (Set SomeΣVar, Set SomeΣVar) Identity (Const1 () a1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeRegisters a1 -> State (Set SomeΣVar, Set SomeΣVar) ()
forall k (a :: k).
FreeRegisters a -> State (Set SomeΣVar, Set SomeΣVar) ()
doFreeRegisters) Combinator FreeRegisters a
p; () -> State (Set SomeΣVar, Set SomeΣVar) ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

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

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