{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections    #-}

-- live intervals
module LI ( intervals ) where

import           CF
import           Control.Monad.State.Strict (execState, get, put)
import           Data.Copointed
import           Data.Foldable              (traverse_)
import qualified Data.IntMap.Lazy           as IM
import qualified Data.IntSet                as IS

collate :: IM.IntMap Int -> IM.IntMap IS.IntSet
collate :: IntMap Int -> IntMap IntSet
collate = (IntSet -> IntSet -> IntSet) -> [IntMap IntSet] -> IntMap IntSet
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IM.unionsWith IntSet -> IntSet -> IntSet
IS.union ([IntMap IntSet] -> IntMap IntSet)
-> (IntMap Int -> [IntMap IntSet]) -> IntMap Int -> IntMap IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> IntMap IntSet) -> [(Int, Int)] -> [IntMap IntSet]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> IntMap IntSet
g ([(Int, Int)] -> [IntMap IntSet])
-> (IntMap Int -> [(Int, Int)]) -> IntMap Int -> [IntMap IntSet]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
IM.toList where g :: (Int, Int) -> IntMap IntSet
g (Int
r, Int
n) = Int -> IntSet -> IntMap IntSet
forall a. Int -> a -> IntMap a
IM.singleton Int
n (Int -> IntSet
IS.singleton Int
r)

fpF :: forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
fpF [p NLiveness]
is = (IntSet, IntMap Int) -> IntMap Int
forall a b. (a, b) -> b
snd ((IntSet, IntMap Int) -> IntMap Int)
-> (IntSet, IntMap Int) -> IntMap Int
forall a b. (a -> b) -> a -> b
$ State (IntSet, IntMap Int) ()
-> (IntSet, IntMap Int) -> (IntSet, IntMap Int)
forall s a. State s a -> s -> s
execState ((p NLiveness -> State (IntSet, IntMap Int) ())
-> [p NLiveness] -> State (IntSet, IntMap Int) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ p NLiveness -> State (IntSet, IntMap Int) ()
forall {m :: * -> *} {p :: * -> *}.
(MonadState (IntSet, IntMap Int) m, Copointed p) =>
p NLiveness -> m ()
g [p NLiveness]
is) (IntSet
IS.empty, IntMap Int
forall a. IntMap a
IM.empty) where
    g :: p NLiveness -> m ()
g p NLiveness
x = do
        (previouslySeen, upd) <- m (IntSet, IntMap Int)
forall s (m :: * -> *). MonadState s m => m s
get
        let ann = p NLiveness -> NLiveness
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint p NLiveness
x
            potentiallyNew = let lx :: Liveness
lx = NLiveness -> Liveness
liveness NLiveness
ann in Liveness -> IntSet
fins Liveness
lx IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> Liveness -> IntSet
fout Liveness
lx
            newS = IntSet
potentiallyNew IntSet -> IntSet -> IntSet
IS.\\ IntSet
previouslySeen
            nAt = [(Int, Int)] -> IntMap Int
forall a. [(Int, a)] -> IntMap a
IM.fromList ((Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,NLiveness -> Int
nx NLiveness
ann) (IntSet -> [Int]
IS.toList IntSet
newS))
        put (previouslySeen `IS.union` newS, nAt `IM.union` upd)

-- forward pass (first mentioned, indexed by register)
fpF, pF :: Copointed p => [p NLiveness] -> IM.IntMap Int
pF :: forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
pF [p NLiveness]
is = (IntSet, IntMap Int) -> IntMap Int
forall a b. (a, b) -> b
snd ((IntSet, IntMap Int) -> IntMap Int)
-> (IntSet, IntMap Int) -> IntMap Int
forall a b. (a -> b) -> a -> b
$ State (IntSet, IntMap Int) ()
-> (IntSet, IntMap Int) -> (IntSet, IntMap Int)
forall s a. State s a -> s -> s
execState ((p NLiveness -> State (IntSet, IntMap Int) ())
-> [p NLiveness] -> State (IntSet, IntMap Int) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ p NLiveness -> State (IntSet, IntMap Int) ()
forall {m :: * -> *} {p :: * -> *}.
(MonadState (IntSet, IntMap Int) m, Copointed p) =>
p NLiveness -> m ()
g [p NLiveness]
is) (IntSet
IS.empty, IntMap Int
forall a. IntMap a
IM.empty) where
    g :: p NLiveness -> m ()
g p NLiveness
x = do
        (previouslySeen, upd) <- m (IntSet, IntMap Int)
forall s (m :: * -> *). MonadState s m => m s
get
        let ann = p NLiveness -> NLiveness
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint p NLiveness
x
            potentiallyNew = let lx :: Liveness
lx = NLiveness -> Liveness
liveness NLiveness
ann in Liveness -> IntSet
ins Liveness
lx IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> Liveness -> IntSet
out Liveness
lx
            newS = IntSet
potentiallyNew IntSet -> IntSet -> IntSet
IS.\\ IntSet
previouslySeen
            nAt = [(Int, Int)] -> IntMap Int
forall a. [(Int, a)] -> IntMap a
IM.fromList ((Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,NLiveness -> Int
nx NLiveness
ann) (IntSet -> [Int]
IS.toList IntSet
newS))
        put (previouslySeen `IS.union` newS, nAt `IM.union` upd)

-- backward pass (last mentioned, ...)
pB, fpB :: Copointed p => [p NLiveness] -> IM.IntMap Int
pB :: forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
pB = [p NLiveness] -> IntMap Int
forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
pF([p NLiveness] -> IntMap Int)
-> ([p NLiveness] -> [p NLiveness]) -> [p NLiveness] -> IntMap Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[p NLiveness] -> [p NLiveness]
forall a. [a] -> [a]
reverse
fpB :: forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
fpB = [p NLiveness] -> IntMap Int
forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
fpF([p NLiveness] -> IntMap Int)
-> ([p NLiveness] -> [p NLiveness]) -> [p NLiveness] -> IntMap Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[p NLiveness] -> [p NLiveness]
forall a. [a] -> [a]
reverse

intervals :: (Copointed p) => [p NLiveness] -> [p Live]
intervals :: forall (p :: * -> *). Copointed p => [p NLiveness] -> [p Live]
intervals [p NLiveness]
asms = (p NLiveness -> p Live) -> [p NLiveness] -> [p Live]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NLiveness -> Live) -> p NLiveness -> p Live
forall a b. (a -> b) -> p a -> p b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NLiveness -> Live
lookupL) [p NLiveness]
asms
    where lookupL :: NLiveness -> Live
lookupL NLiveness
x = let n :: Int
n = NLiveness -> Int
nx NLiveness
x in IntSet -> IntSet -> IntSet -> IntSet -> Live
Live (Int -> IntMap IntSet -> IntSet
lI Int
n IntMap IntSet
findFirst) (Int -> IntMap IntSet -> IntSet
lI Int
n IntMap IntSet
findLast) (Int -> IntMap IntSet -> IntSet
lI Int
n IntMap IntSet
findFirstF) (Int -> IntMap IntSet -> IntSet
lI Int
n IntMap IntSet
findLastF)
          lI :: Int -> IntMap IntSet -> IntSet
lI = IntSet -> Int -> IntMap IntSet -> IntSet
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault IntSet
IS.empty
          findFirst :: IntMap IntSet
findFirst = IntMap Int -> IntMap IntSet
collate ([p NLiveness] -> IntMap Int
forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
pF [p NLiveness]
asms)
          findLast :: IntMap IntSet
findLast = IntMap Int -> IntMap IntSet
collate ([p NLiveness] -> IntMap Int
forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
pB [p NLiveness]
asms)
          findFirstF :: IntMap IntSet
findFirstF = IntMap Int -> IntMap IntSet
collate ([p NLiveness] -> IntMap Int
forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
fpF [p NLiveness]
asms)
          findLastF :: IntMap IntSet
findLastF = IntMap Int -> IntMap IntSet
collate ([p NLiveness] -> IntMap Int
forall (p :: * -> *). Copointed p => [p NLiveness] -> IntMap Int
fpB [p NLiveness]
asms)