{-# LANGUAGE TupleSections #-}

module IR.Hoist ( loop, hoist, pall ) where

import           CF
import           Control.Composition        (thread)
import           Control.Monad.State.Strict (gets, modify, runState)
import qualified Data.Array                 as A
import           Data.Bifunctor             (bimap, first, second)
import           Data.Foldable              (toList)
import           Data.Function              (on)
import           Data.Functor               (($>))
import           Data.Graph                 (Tree (Node))
import           Data.Graph.Dom             (Graph, Node, domTree)
import qualified Data.IntMap                as IM
import qualified Data.IntSet                as IS
import           Data.List                  (sortBy)
import qualified Data.Map.Strict            as M
import           Data.Maybe                 (catMaybes, fromJust, fromMaybe)
import           Data.Tuple.Extra           (first3, snd3)
import           IR
import           IR.CF
import           LR

type N=Int

mapFA :: (FTemp -> FTemp) -> AE -> AE
mapFA :: (FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f (AP Temp
t (Just Exp
e) Maybe AL
l) = Temp -> Maybe Exp -> Maybe AL -> AE
AP Temp
t (Exp -> Maybe Exp
forall a. a -> Maybe a
Just(Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$(FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e) Maybe AL
l
mapFA FTemp -> FTemp
_ AE
a                 = AE
a

mapFE :: (FTemp -> FTemp) -> Exp -> Exp
mapFE :: (FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f (IRFloor FExp
x)      = FExp -> Exp
IRFloor ((FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
f FExp
x)
mapFE FTemp -> FTemp
f (EAt AE
a)          = AE -> Exp
EAt ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a)
mapFE FTemp -> FTemp
f (BAt AE
a)          = AE -> Exp
BAt ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a)
mapFE FTemp -> FTemp
_ e :: Exp
e@ConstI{}       = Exp
e
mapFE FTemp -> FTemp
_ e :: Exp
e@Reg{}          = Exp
e
mapFE FTemp -> FTemp
_ e :: Exp
e@Is{}           = Exp
e
mapFE FTemp -> FTemp
f (FRel FRel
rel FExp
x0 FExp
x1) = FRel -> FExp -> FExp -> Exp
FRel FRel
rel ((FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
f FExp
x0) ((FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
f FExp
x1)
mapFE FTemp -> FTemp
f (IB IBin
op Exp
e0 Exp
e1)    = IBin -> Exp -> Exp -> Exp
IB IBin
op ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e0) ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e1)
mapFE FTemp -> FTemp
f (IU IUn
op Exp
e)        = IUn -> Exp -> Exp
IU IUn
op ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapFE FTemp -> FTemp
f (BU BUn
op Exp
e)        = BUn -> Exp -> Exp
BU BUn
op ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapFE FTemp -> FTemp
f (IRel IRel
rel Exp
e0 Exp
e1) = IRel -> Exp -> Exp -> Exp
IRel IRel
rel ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e0) ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e1)
mapFE FTemp -> FTemp
_ e :: Exp
e@LA{}           = Exp
e

mapFF :: (FTemp -> FTemp) -> FExp -> FExp
mapFF :: (FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
_ x :: FExp
x@ConstF{}    = FExp
x
mapFF FTemp -> FTemp
f (FAt AE
a)       = AE -> FExp
FAt ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a)
mapFF FTemp -> FTemp
f (FB FBin
op FExp
e0 FExp
e1) = FBin -> FExp -> FExp -> FExp
FB FBin
op ((FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
f FExp
e0) ((FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
f FExp
e1)
mapFF FTemp -> FTemp
f (FU FUn
op FExp
e)     = FUn -> FExp -> FExp
FU FUn
op ((FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
f FExp
e)
mapFF FTemp -> FTemp
f (FReg FTemp
r)      = FTemp -> FExp
FReg (FTemp -> FTemp
f FTemp
r)
mapFF FTemp -> FTemp
f (FConv Exp
e)     = Exp -> FExp
FConv ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)

mapF :: (FTemp -> FTemp) -> Stmt -> Stmt
mapF :: (FTemp -> FTemp) -> Stmt -> Stmt
mapF FTemp -> FTemp
f (MX FTemp
t FExp
e)       = FTemp -> FExp -> Stmt
MX (FTemp -> FTemp
f FTemp
t) ((FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
f FExp
e)
mapF FTemp -> FTemp
_ s :: Stmt
s@L{}          = Stmt
s
mapF FTemp -> FTemp
_ s :: Stmt
s@C{}          = Stmt
s
mapF FTemp -> FTemp
_ s :: Stmt
s@R{}          = Stmt
s
mapF FTemp -> FTemp
_ s :: Stmt
s@IRnd{}       = Stmt
s
mapF FTemp -> FTemp
f (FRnd FTemp
t)       = FTemp -> Stmt
FRnd (FTemp -> FTemp
f FTemp
t)
mapF FTemp -> FTemp
_ s :: Stmt
s@J{}          = Stmt
s
mapF FTemp -> FTemp
_ s :: Stmt
s@Free{}       = Stmt
s
mapF FTemp -> FTemp
_ s :: Stmt
s@RA{}         = Stmt
s
mapF FTemp -> FTemp
f (MT Temp
t Exp
e)       = Temp -> Exp -> Stmt
MT Temp
t ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapF FTemp -> FTemp
f (Wr AE
a Exp
e)       = AE -> Exp -> Stmt
Wr ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a) ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapF FTemp -> FTemp
f (WrF AE
a FExp
x)      = AE -> FExp -> Stmt
WrF ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a) ((FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
f FExp
x)
mapF FTemp -> FTemp
f (WrB AE
a Exp
e)      = AE -> Exp -> Stmt
WrB ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a) ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapF FTemp -> FTemp
f (Fcmov Exp
e FTemp
t FExp
x)  = Exp -> FTemp -> FExp -> Stmt
Fcmov ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e) (FTemp -> FTemp
f FTemp
t) ((FTemp -> FTemp) -> FExp -> FExp
mapFF FTemp -> FTemp
f FExp
x)
mapF FTemp -> FTemp
f (MJ Exp
e Label
l)       = Exp -> Label -> Stmt
MJ ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e) Label
l
mapF FTemp -> FTemp
f (Ma AL
l Temp
t Exp
e)     = AL -> Temp -> Exp -> Stmt
Ma AL
l Temp
t ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapF FTemp -> FTemp
f (Sa Temp
t Exp
e)       = Temp -> Exp -> Stmt
Sa Temp
t ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapF FTemp -> FTemp
f (Pop Exp
e)        = Exp -> Stmt
Pop ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapF FTemp -> FTemp
f (Cpy AE
a0 AE
a1 Exp
e)  = AE -> AE -> Exp -> Stmt
Cpy ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a0) ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a1) ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapF FTemp -> FTemp
f (Cpy1 AE
a0 AE
a1 Exp
e) = AE -> AE -> Exp -> Stmt
Cpy1 ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a0) ((FTemp -> FTemp) -> AE -> AE
mapFA FTemp -> FTemp
f AE
a1) ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapF FTemp -> FTemp
f (Cmov Exp
p Temp
t Exp
e)   = Exp -> Temp -> Exp -> Stmt
Cmov ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
p) Temp
t ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
e)
mapF FTemp -> FTemp
f (Cset Temp
t Exp
p)     = Temp -> Exp -> Stmt
Cset Temp
t ((FTemp -> FTemp) -> Exp -> Exp
mapFE FTemp -> FTemp
f Exp
p)

type Loop = (N, IS.IntSet)

-- TODO: array?
lm :: [(Stmt, NLiveness)] -> IM.IntMap NLiveness
lm :: [(Stmt, NLiveness)] -> IntMap NLiveness
lm = [(Int, NLiveness)] -> IntMap NLiveness
forall a. [(Int, a)] -> IntMap a
IM.fromList([(Int, NLiveness)] -> IntMap NLiveness)
-> ([(Stmt, NLiveness)] -> [(Int, NLiveness)])
-> [(Stmt, NLiveness)]
-> IntMap NLiveness
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Stmt, NLiveness) -> (Int, NLiveness))
-> [(Stmt, NLiveness)] -> [(Int, NLiveness)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Stmt
_,NLiveness
n) -> (NLiveness -> Int
nx NLiveness
n, NLiveness
n))

hl :: (Loop, A.Array Int (Stmt, ControlAnn), IM.IntMap NLiveness) -> [(N, N, (FTemp, Double))]
hl :: (Loop, Array Int (Stmt, ControlAnn), IntMap NLiveness)
-> [(Int, Int, (FTemp, Double))]
hl ((Int
n,IntSet
ns), Array Int (Stmt, ControlAnn)
info, IntMap NLiveness
linfo) = [(Stmt, ControlAnn)] -> [(Int, Int, (FTemp, Double))]
go [(Stmt, ControlAnn)]
ss
  where
    lH :: Liveness
lH=NLiveness -> Liveness
liveness (Int -> IntMap NLiveness -> NLiveness
forall {a}. Int -> IntMap a -> a
gN Int
n IntMap NLiveness
linfo)
    fliveInH :: IntSet
fliveInH=Liveness -> IntSet
fins Liveness
lH
    go :: [(Stmt, ControlAnn)] -> [(Int, Int, (FTemp, Double))]
go ((MX FTemp
x (ConstF Double
i), ControlAnn
a):[(Stmt, ControlAnn)]
ssϵ) | FTemp -> Int
fToInt FTemp
x Int -> IntSet -> Bool
`IS.notMember` IntSet
fliveInH Bool -> Bool -> Bool
&& FTemp -> Int -> Bool
notFDef FTemp
x (ControlAnn -> Int
node ControlAnn
a) = (Int
n, ControlAnn -> Int
node ControlAnn
a, (FTemp
x,Double
i))(Int, Int, (FTemp, Double))
-> [(Int, Int, (FTemp, Double))] -> [(Int, Int, (FTemp, Double))]
forall a. a -> [a] -> [a]
:[(Stmt, ControlAnn)] -> [(Int, Int, (FTemp, Double))]
go [(Stmt, ControlAnn)]
ssϵ
    go ((Stmt, ControlAnn)
_:[(Stmt, ControlAnn)]
ssϵ)                      = [(Stmt, ControlAnn)] -> [(Int, Int, (FTemp, Double))]
go [(Stmt, ControlAnn)]
ssϵ
    go []                           = []
    otherDefFs :: Int -> [IntSet]
otherDefFs Int
nL = UD -> IntSet
defsFNode(UD -> IntSet) -> (Int -> UD) -> Int -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ControlAnn -> UD
ud(ControlAnn -> UD) -> (Int -> ControlAnn) -> Int -> UD
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Stmt, ControlAnn) -> ControlAnn
forall a b. (a, b) -> b
snd((Stmt, ControlAnn) -> ControlAnn)
-> (Int -> (Stmt, ControlAnn)) -> Int -> ControlAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Array Int (Stmt, ControlAnn)
info Array Int (Stmt, ControlAnn) -> Int -> (Stmt, ControlAnn)
forall i e. Ix i => Array i e -> i -> e
A.!)(Int -> IntSet) -> [Int] -> [IntSet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>IntSet -> [Int]
IS.toList(Int -> IntSet -> IntSet
IS.delete Int
nL IntSet
ns)
    notFDef :: FTemp -> Int -> Bool
notFDef FTemp
r Int
nL = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (IntSet -> Bool) -> [IntSet] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FTemp -> Int
fToInt FTemp
r Int -> IntSet -> Bool
`IS.member`) (Int -> [IntSet]
otherDefFs Int
nL)
    ss :: [(Stmt, ControlAnn)]
ss = (Array Int (Stmt, ControlAnn)
info Array Int (Stmt, ControlAnn) -> Int -> (Stmt, ControlAnn)
forall i e. Ix i => Array i e -> i -> e
A.!)(Int -> (Stmt, ControlAnn)) -> [Int] -> [(Stmt, ControlAnn)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>IntSet -> [Int]
IS.toList IntSet
ns
    gN :: Int -> IntMap a -> a
gN = a -> Int -> IntMap a -> a
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: node not in map.")

pall :: [Stmt] -> [Stmt]
pall :: [Stmt] -> [Stmt]
pall [Stmt]
ss =
    let ss' :: [(Stmt, Int)]
ss' = ((Stmt, ControlAnn) -> (Stmt, Int))
-> [(Stmt, ControlAnn)] -> [(Stmt, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ControlAnn -> Int) -> (Stmt, ControlAnn) -> (Stmt, Int)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ControlAnn -> Int
node) [(Stmt, ControlAnn)]
cf
        (Map FTemp FTemp
s, [Stmt]
ss'') = [(Stmt, Int)] -> (Map FTemp FTemp, [Stmt])
go [(Stmt, Int)]
ss'
    in {-# SCC "applySubst" #-} Map FTemp FTemp -> [Stmt] -> [Stmt]
forall {f :: * -> *}.
Functor f =>
Map FTemp FTemp -> f Stmt -> f Stmt
applySubst Map FTemp FTemp
s [Stmt]
ss''
  where
    go :: [(Stmt, Int)] -> (Map FTemp FTemp, [Stmt])
go ((Stmt
_,Int
n):[(Stmt, Int)]
ssϵ) | Int
n Int -> IntSet -> Bool
`IS.member` IntSet
dels = [(Stmt, Int)] -> (Map FTemp FTemp, [Stmt])
go [(Stmt, Int)]
ssϵ
    go ((Stmt
s,Int
n):[(Stmt, Int)]
ssϵ) | Just [(FTemp, Double)]
cs <- Int -> IntMap [(FTemp, Double)] -> Maybe [(FTemp, Double)]
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n IntMap [(FTemp, Double)]
is = let ([Stmt]
css, (Map Double FTemp
_, Map FTemp FTemp
subst)) = {-# SCC "consolidate" #-} [(FTemp, Double)] -> ([Stmt], (Map Double FTemp, Map FTemp FTemp))
consolidate [(FTemp, Double)]
cs in (Map FTemp FTemp -> Map FTemp FTemp)
-> ([Stmt] -> [Stmt])
-> (Map FTemp FTemp, [Stmt])
-> (Map FTemp FTemp, [Stmt])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Map FTemp FTemp
substMap FTemp FTemp -> Map FTemp FTemp -> Map FTemp FTemp
forall a. Semigroup a => a -> a -> a
<>) (([Stmt]
css[Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++[Stmt
s])[Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++) ([(Stmt, Int)] -> (Map FTemp FTemp, [Stmt])
go [(Stmt, Int)]
ssϵ)
    go ((Stmt
s,Int
_):[(Stmt, Int)]
ssϵ) = ([Stmt] -> [Stmt])
-> (Map FTemp FTemp, [Stmt]) -> (Map FTemp FTemp, [Stmt])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Stmt
sStmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
:)((Map FTemp FTemp, [Stmt]) -> (Map FTemp FTemp, [Stmt]))
-> (Map FTemp FTemp, [Stmt]) -> (Map FTemp FTemp, [Stmt])
forall a b. (a -> b) -> a -> b
$[(Stmt, Int)] -> (Map FTemp FTemp, [Stmt])
go [(Stmt, Int)]
ssϵ
    go [] = (Map FTemp FTemp
forall k a. Map k a
M.empty, [])
    ([(Stmt, ControlAnn)]
cf, IntMap [(FTemp, Double)]
is, IntSet
dels) = [Stmt] -> ([(Stmt, ControlAnn)], IntMap [(FTemp, Double)], IntSet)
indels [Stmt]
ss
    applySubst :: Map FTemp FTemp -> f Stmt -> f Stmt
applySubst Map FTemp FTemp
s = (Stmt -> Stmt) -> f Stmt -> f Stmt
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FTemp -> FTemp) -> Stmt -> Stmt
mapF (\FTemp
t -> FTemp -> Maybe FTemp -> FTemp
forall a. a -> Maybe a -> a
fromMaybe FTemp
t (FTemp -> Map FTemp FTemp -> Maybe FTemp
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FTemp
t Map FTemp FTemp
s)))
    consolidate :: [(FTemp, Double)] -> ([Stmt], (Map Double FTemp, Map FTemp FTemp))
consolidate = ([Maybe Stmt] -> [Stmt])
-> ([Maybe Stmt], (Map Double FTemp, Map FTemp FTemp))
-> ([Stmt], (Map Double FTemp, Map FTemp FTemp))
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Maybe Stmt] -> [Stmt]
forall a. [Maybe a] -> [a]
catMaybes (([Maybe Stmt], (Map Double FTemp, Map FTemp FTemp))
 -> ([Stmt], (Map Double FTemp, Map FTemp FTemp)))
-> ([(FTemp, Double)]
    -> ([Maybe Stmt], (Map Double FTemp, Map FTemp FTemp)))
-> [(FTemp, Double)]
-> ([Stmt], (Map Double FTemp, Map FTemp FTemp))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State (Map Double FTemp, Map FTemp FTemp) [Maybe Stmt]
 -> (Map Double FTemp, Map FTemp FTemp)
 -> ([Maybe Stmt], (Map Double FTemp, Map FTemp FTemp)))
-> (Map Double FTemp, Map FTemp FTemp)
-> State (Map Double FTemp, Map FTemp FTemp) [Maybe Stmt]
-> ([Maybe Stmt], (Map Double FTemp, Map FTemp FTemp))
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Map Double FTemp, Map FTemp FTemp) [Maybe Stmt]
-> (Map Double FTemp, Map FTemp FTemp)
-> ([Maybe Stmt], (Map Double FTemp, Map FTemp FTemp))
forall s a. State s a -> s -> (a, s)
runState (Map Double FTemp
forall k a. Map k a
M.empty, Map FTemp FTemp
forall k a. Map k a
M.empty) (State (Map Double FTemp, Map FTemp FTemp) [Maybe Stmt]
 -> ([Maybe Stmt], (Map Double FTemp, Map FTemp FTemp)))
-> ([(FTemp, Double)]
    -> State (Map Double FTemp, Map FTemp FTemp) [Maybe Stmt])
-> [(FTemp, Double)]
-> ([Maybe Stmt], (Map Double FTemp, Map FTemp FTemp))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FTemp, Double)
 -> StateT
      (Map Double FTemp, Map FTemp FTemp) Identity (Maybe Stmt))
-> [(FTemp, Double)]
-> State (Map Double FTemp, Map FTemp FTemp) [Maybe Stmt]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(FTemp
t,Double
x) -> do
        seen <- ((Map Double FTemp, Map FTemp FTemp) -> Map Double FTemp)
-> StateT
     (Map Double FTemp, Map FTemp FTemp) Identity (Map Double FTemp)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Map Double FTemp, Map FTemp FTemp) -> Map Double FTemp
forall a b. (a, b) -> a
fst
        case M.lookup x seen of
            Maybe FTemp
Nothing -> ((Map Double FTemp, Map FTemp FTemp)
 -> (Map Double FTemp, Map FTemp FTemp))
-> StateT (Map Double FTemp, Map FTemp FTemp) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map Double FTemp -> Map Double FTemp)
-> (Map Double FTemp, Map FTemp FTemp)
-> (Map Double FTemp, Map FTemp FTemp)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Double -> FTemp -> Map Double FTemp -> Map Double FTemp
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Double
x FTemp
t)) StateT (Map Double FTemp, Map FTemp FTemp) Identity ()
-> Maybe Stmt
-> StateT (Map Double FTemp, Map FTemp FTemp) Identity (Maybe Stmt)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Stmt -> Maybe Stmt
forall a. a -> Maybe a
Just (FTemp -> FExp -> Stmt
MX FTemp
t (Double -> FExp
ConstF Double
x))
            Just FTemp
r  -> ((Map Double FTemp, Map FTemp FTemp)
 -> (Map Double FTemp, Map FTemp FTemp))
-> StateT (Map Double FTemp, Map FTemp FTemp) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map FTemp FTemp -> Map FTemp FTemp)
-> (Map Double FTemp, Map FTemp FTemp)
-> (Map Double FTemp, Map FTemp FTemp)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (FTemp -> FTemp -> Map FTemp FTemp -> Map FTemp FTemp
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FTemp
t FTemp
r)) StateT (Map Double FTemp, Map FTemp FTemp) Identity ()
-> Maybe Stmt
-> StateT (Map Double FTemp, Map FTemp FTemp) Identity (Maybe Stmt)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe Stmt
forall a. Maybe a
Nothing)

indels :: [Stmt] -> ([(Stmt, ControlAnn)], IM.IntMap [(FTemp, Double)], IS.IntSet)
indels :: [Stmt] -> ([(Stmt, ControlAnn)], IntMap [(FTemp, Double)], IntSet)
indels [Stmt]
ss = ([(Stmt, ControlAnn)]
c, IntMap [(FTemp, Double)] -> IntMap [(FTemp, Double)]
is IntMap [(FTemp, Double)]
forall a. IntMap a
IM.empty, IntSet
ds)
  where
    ([(Stmt, ControlAnn)]
c,[(Int, Int, (FTemp, Double))]
h) = [Stmt] -> ([(Stmt, ControlAnn)], [(Int, Int, (FTemp, Double))])
hs [Stmt]
ss
    ds :: IntSet
ds = [Int] -> IntSet
IS.fromList ((Int, Int, (FTemp, Double)) -> Int
forall a b c. (a, b, c) -> b
snd3((Int, Int, (FTemp, Double)) -> Int)
-> [(Int, Int, (FTemp, Double))] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>[(Int, Int, (FTemp, Double))]
h)
    go :: Int -> a -> IntMap [a] -> IntMap [a]
go Int
n a
s = (Maybe [a] -> Maybe [a]) -> Int -> IntMap [a] -> IntMap [a]
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter (\Maybe [a]
d -> case Maybe [a]
d of {Maybe [a]
Nothing -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
s]; Just [a]
ssϵ -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just([a] -> Maybe [a]) -> [a] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$a
sa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ssϵ}) Int
n
    is :: IntMap [(FTemp, Double)] -> IntMap [(FTemp, Double)]
is = [IntMap [(FTemp, Double)] -> IntMap [(FTemp, Double)]]
-> IntMap [(FTemp, Double)] -> IntMap [(FTemp, Double)]
forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread ((\(Int
n,Int
_,(FTemp, Double)
s) -> Int
-> (FTemp, Double)
-> IntMap [(FTemp, Double)]
-> IntMap [(FTemp, Double)]
forall {a}. Int -> a -> IntMap [a] -> IntMap [a]
go Int
n (FTemp, Double)
s)((Int, Int, (FTemp, Double))
 -> IntMap [(FTemp, Double)] -> IntMap [(FTemp, Double)])
-> [(Int, Int, (FTemp, Double))]
-> [IntMap [(FTemp, Double)] -> IntMap [(FTemp, Double)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>[(Int, Int, (FTemp, Double))]
h)

hs :: [Stmt] -> ([(Stmt, ControlAnn)], [(N, N, (FTemp, Double))])
hs :: [Stmt] -> ([(Stmt, ControlAnn)], [(Int, Int, (FTemp, Double))])
hs [Stmt]
ss = let ([Loop]
ls, [(Stmt, ControlAnn)]
cf, Array Int (Stmt, ControlAnn)
dm) = [Stmt]
-> ([Loop], [(Stmt, ControlAnn)], Array Int (Stmt, ControlAnn))
loop [Stmt]
ss
            mm :: IntMap NLiveness
mm = [(Stmt, NLiveness)] -> IntMap NLiveness
lm ([(Stmt, ControlAnn)] -> [(Stmt, NLiveness)]
forall {p :: * -> *}.
Copointed p =>
[p ControlAnn] -> [p NLiveness]
reconstructFlat [(Stmt, ControlAnn)]
cf)
     in ([(Stmt, ControlAnn)]
cf, (Loop -> [(Int, Int, (FTemp, Double))])
-> [Loop] -> [(Int, Int, (FTemp, Double))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Loop
l -> (Loop, Array Int (Stmt, ControlAnn), IntMap NLiveness)
-> [(Int, Int, (FTemp, Double))]
hl (Loop
l,Array Int (Stmt, ControlAnn)
dm,IntMap NLiveness
mm)) ([Loop] -> [Loop]
ols [Loop]
ls))

loop :: [Stmt] -> ([Loop], [(Stmt, ControlAnn)], A.Array Int (Stmt, ControlAnn))
loop :: [Stmt]
-> ([Loop], [(Stmt, ControlAnn)], Array Int (Stmt, ControlAnn))
loop = ([(Int, [Int])] -> [Loop])
-> ([(Int, [Int])], [(Stmt, ControlAnn)],
    Array Int (Stmt, ControlAnn))
-> ([Loop], [(Stmt, ControlAnn)], Array Int (Stmt, ControlAnn))
forall a a' b c. (a -> a') -> (a, b, c) -> (a', b, c)
first3 (((Int, [Int]) -> Loop) -> [(Int, [Int])] -> [Loop]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, [Int]) -> Loop
forall {a}. (a, [Int]) -> (a, IntSet)
mkL)(([(Int, [Int])], [(Stmt, ControlAnn)],
  Array Int (Stmt, ControlAnn))
 -> ([Loop], [(Stmt, ControlAnn)], Array Int (Stmt, ControlAnn)))
-> ([Stmt]
    -> ([(Int, [Int])], [(Stmt, ControlAnn)],
        Array Int (Stmt, ControlAnn)))
-> [Stmt]
-> ([Loop], [(Stmt, ControlAnn)], Array Int (Stmt, ControlAnn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(\(Graph
w,Tree Int
x,[(Stmt, ControlAnn)]
y,Array Int (Stmt, ControlAnn)
z) -> (Graph -> Array Int Stmt -> [Int] -> Tree Int -> [(Int, [Int])]
et Graph
w (((Stmt, ControlAnn) -> Stmt)
-> Array Int (Stmt, ControlAnn) -> Array Int Stmt
forall a b. (a -> b) -> Array Int a -> Array Int b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Stmt, ControlAnn) -> Stmt
forall a b. (a, b) -> a
fst Array Int (Stmt, ControlAnn)
z) [] Tree Int
x,[(Stmt, ControlAnn)]
y,Array Int (Stmt, ControlAnn)
z))((Graph, Tree Int, [(Stmt, ControlAnn)],
  Array Int (Stmt, ControlAnn))
 -> ([(Int, [Int])], [(Stmt, ControlAnn)],
     Array Int (Stmt, ControlAnn)))
-> ([Stmt]
    -> (Graph, Tree Int, [(Stmt, ControlAnn)],
        Array Int (Stmt, ControlAnn)))
-> [Stmt]
-> ([(Int, [Int])], [(Stmt, ControlAnn)],
    Array Int (Stmt, ControlAnn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Stmt]
-> (Graph, Tree Int, [(Stmt, ControlAnn)],
    Array Int (Stmt, ControlAnn))
hoist
  where
    mkL :: (a, [Int]) -> (a, IntSet)
mkL (a
n, [Int]
ns) = (a
n, [Int] -> IntSet
IS.fromList [Int]
ns)

hoist :: [Stmt] -> (Graph, Tree N, [(Stmt, ControlAnn)], A.Array Int (Stmt, ControlAnn))
hoist :: [Stmt]
-> (Graph, Tree Int, [(Stmt, ControlAnn)],
    Array Int (Stmt, ControlAnn))
hoist [Stmt]
ss = (\([(Stmt, ControlAnn)], Int)
ssϵ -> (\(Graph
x,Tree Int
y,Array Int (Stmt, ControlAnn)
z,IntMap (Stmt, ControlAnn)
_) -> (Graph
x,Tree Int
y,([(Stmt, ControlAnn)], Int) -> [(Stmt, ControlAnn)]
forall a b. (a, b) -> a
fst ([(Stmt, ControlAnn)], Int)
ssϵ,Array Int (Stmt, ControlAnn)
z))((Graph, Tree Int, Array Int (Stmt, ControlAnn),
  IntMap (Stmt, ControlAnn))
 -> (Graph, Tree Int, [(Stmt, ControlAnn)],
     Array Int (Stmt, ControlAnn)))
-> (Graph, Tree Int, Array Int (Stmt, ControlAnn),
    IntMap (Stmt, ControlAnn))
-> (Graph, Tree Int, [(Stmt, ControlAnn)],
    Array Int (Stmt, ControlAnn))
forall a b. (a -> b) -> a -> b
$([(Stmt, ControlAnn)], Int)
-> (Graph, Tree Int, Array Int (Stmt, ControlAnn),
    IntMap (Stmt, ControlAnn))
mkG ([(Stmt, ControlAnn)], Int)
ssϵ) ([Stmt] -> ([(Stmt, ControlAnn)], Int)
mkControlFlow [Stmt]
ss)

{-# SCC ols #-}
ols :: [Loop] -> [Loop]
ols :: [Loop] -> [Loop]
ols [Loop]
ls = (Loop -> Bool) -> [Loop] -> [Loop]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_,IntSet
ns) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Loop -> Bool) -> [Loop] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Int
_,IntSet
ns') -> IntSet
ns IntSet -> IntSet -> Bool
`IS.isProperSubsetOf` IntSet
ns') [Loop]
ls) [Loop]
ls

et :: Graph -> A.Array Int Stmt -> [N] -> Tree N -> [(N, [N])]
et :: Graph -> Array Int Stmt -> [Int] -> Tree Int -> [(Int, [Int])]
et Graph
g Array Int Stmt
ss [Int]
seen Tree Int
t = Tree Int -> Int -> (Int, [Int])
expandLoop Tree Int
t (Int -> (Int, [Int])) -> [Int] -> [(Int, [Int])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph -> Array Int Stmt -> [Int] -> Tree Int -> [Int]
loopHeads Graph
g Array Int Stmt
ss [Int]
seen Tree Int
t

-- everything the start node dominates
expandLoop :: Tree N -> N -> (N,[N])
--- wir müssen wissen, wir werden wissen
expandLoop :: Tree Int -> Int -> (Int, [Int])
expandLoop Tree Int
t Int
s = (Int
s, Maybe [Int] -> [Int]
forall a. HasCallStack => Maybe a -> a
fromJust (Tree Int -> Maybe [Int]
go Tree Int
t))
  where
    go :: Tree Int -> Maybe [Int]
go (Node Int
n [Tree Int]
tϵ) | Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
s = [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just([Int] -> Maybe [Int]) -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$(Tree Int -> [Int]) -> [Tree Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Int -> [Int]
forall a. Tree a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [Tree Int]
tϵ
    go (Node Int
_ [Tree Int]
ns) = [Maybe [Int]] -> Maybe [Int]
forall {a}. [Maybe a] -> Maybe a
mh (Tree Int -> Maybe [Int]
go(Tree Int -> Maybe [Int]) -> [Tree Int] -> [Maybe [Int]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>[Tree Int]
ns) where mh :: [Maybe a] -> Maybe a
mh [Maybe a]
xs=case [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes [Maybe a]
xs of {[] -> Maybe a
forall a. Maybe a
Nothing; (a
nϵ:[a]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
nϵ}

loopHeads :: Graph -> A.Array Int Stmt -> [N] -> Tree N -> [N]
loopHeads :: Graph -> Array Int Stmt -> [Int] -> Tree Int -> [Int]
loopHeads Graph
g Array Int Stmt
ss [Int]
seen (Node Int
n [Tree Int]
cs) =
    let bes :: [Int]
bes=(Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Graph -> Int -> Int -> Bool
hasEdge Graph
g Int
n) [Int]
seen
    in (if Int -> Bool
isMJ Int
n then ([Int]
bes[Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++) else [Int] -> [Int]
forall a. a -> a
id) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Tree Int -> [Int]) -> [Tree Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Graph -> Array Int Stmt -> [Int] -> Tree Int -> [Int]
loopHeads Graph
g Array Int Stmt
ss (Int
nInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
seen)) [Tree Int]
cs
  where
    isMJ :: Int -> Bool
isMJ Int
nϵ = Stmt -> Bool
p (Array Int Stmt
ss Array Int Stmt -> Int -> Stmt
forall i e. Ix i => Array i e -> i -> e
A.! Int
nϵ)
    p :: Stmt -> Bool
p MJ{}=Bool
True; p Stmt
_=Bool
False

hasEdge :: Graph -> Node -> Node -> Bool
hasEdge :: Graph -> Int -> Int -> Bool
hasEdge Graph
g Int
n0 Int
n1 = case Int -> Graph -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n0 Graph
g of {Maybe IntSet
Nothing -> Bool
False; Just IntSet
ns -> Int
n1 Int -> IntSet -> Bool
`IS.member` IntSet
ns}

mkG :: ([(Stmt, ControlAnn)], Int) -> (Graph, Tree N, A.Array Int (Stmt, ControlAnn), IM.IntMap (Stmt, ControlAnn))
mkG :: ([(Stmt, ControlAnn)], Int)
-> (Graph, Tree Int, Array Int (Stmt, ControlAnn),
    IntMap (Stmt, ControlAnn))
mkG ([(Stmt, ControlAnn)]
ns,Int
m) = (Graph
domG, Rooted -> Tree Int
domTree (ControlAnn -> Int
node ((Stmt, ControlAnn) -> ControlAnn
forall a b. (a, b) -> b
snd ([(Stmt, ControlAnn)] -> (Stmt, ControlAnn)
forall a. HasCallStack => [a] -> a
head [(Stmt, ControlAnn)]
ns)), Graph
domG), Array Int (Stmt, ControlAnn)
sa, [(Int, (Stmt, ControlAnn))] -> IntMap (Stmt, ControlAnn)
forall a. [(Int, a)] -> IntMap a
IM.fromList ((\(Stmt
s, ControlAnn
ann) -> (ControlAnn -> Int
node ControlAnn
ann, (Stmt
s, ControlAnn
ann)))((Stmt, ControlAnn) -> (Int, (Stmt, ControlAnn)))
-> [(Stmt, ControlAnn)] -> [(Int, (Stmt, ControlAnn))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>[(Stmt, ControlAnn)]
ns))
  where
    domG :: Graph
domG = [Loop] -> Graph
forall a. [(Int, a)] -> IntMap a
IM.fromList [ (ControlAnn -> Int
node ControlAnn
ann, [Int] -> IntSet
IS.fromList (ControlAnn -> [Int]
conn ControlAnn
ann)) | (Stmt
_, ControlAnn
ann) <- [(Stmt, ControlAnn)]
ns ]
    sa :: Array Int (Stmt, ControlAnn)
sa = (Int, Int) -> [(Stmt, ControlAnn)] -> Array Int (Stmt, ControlAnn)
forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
0,Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (((Stmt, ControlAnn) -> (Stmt, ControlAnn) -> Ordering)
-> [(Stmt, ControlAnn)] -> [(Stmt, ControlAnn)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Stmt, ControlAnn) -> Int)
-> (Stmt, ControlAnn)
-> (Stmt, ControlAnn)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ControlAnn -> Int
node(ControlAnn -> Int)
-> ((Stmt, ControlAnn) -> ControlAnn) -> (Stmt, ControlAnn) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Stmt, ControlAnn) -> ControlAnn
forall a b. (a, b) -> b
snd)) [(Stmt, ControlAnn)]
ns)