-- | From Appel
module Asm.G ( alloc, allocF ) where

import           Asm.Ar
import           Asm.BB
import           CF
import           Data.Copointed
import qualified Data.IntMap      as IM
import qualified Data.IntSet      as IS
import qualified Data.Set         as S
import           Data.Tuple.Extra (fst3, snd3, thd3)

type K=Int

-- move list: map from abstract registers (def ∪ used) to nodes
type Movs = IM.IntMap MS
type GS = S.Set (Int, Int)
type GL = IM.IntMap [Int]

-- TODO: might work as lazy lists idk (deletion)
-- difference would still be annoying though...
data Wk = Wk { Wk -> IntSet
pre :: IS.IntSet, Wk -> IntSet
sp :: IS.IntSet, Wk -> IntSet
fr :: IS.IntSet, Wk -> IntSet
simp :: IS.IntSet }

mapSp :: (IntSet -> IntSet) -> Wk -> Wk
mapSp IntSet -> IntSet
f Wk
w = Wk
w { sp = f (sp w) }
mapFr :: (IntSet -> IntSet) -> Wk -> Wk
mapFr IntSet -> IntSet
f Wk
w = Wk
w { fr = f (fr w) }
mapSimp :: (IntSet -> IntSet) -> Wk -> Wk
mapSimp IntSet -> IntSet
f Wk
w = Wk
w { simp = f (simp w) }

type M = (Int, Int); type MS = S.Set M

-- TODO: appel says to make these doubly-linked lists
data Mv = Mv { Mv -> Set (Int, Int)
coal :: MS, Mv -> Set (Int, Int)
constr :: MS, Mv -> Set (Int, Int)
frz :: MS, Mv -> Set (Int, Int)
wl :: MS, Mv -> Set (Int, Int)
actv :: MS }

mapWl :: (Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapWl Set (Int, Int) -> Set (Int, Int)
f Mv
mv = Mv
mv { wl = f (wl mv) }
mapActv :: (Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapActv Set (Int, Int) -> Set (Int, Int)
f Mv
mv = Mv
mv { actv = f (actv mv) }
mapCoal :: (Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapCoal Set (Int, Int) -> Set (Int, Int)
f Mv
mv = Mv
mv { coal = f (coal mv) }
mapFrz :: (Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapFrz Set (Int, Int) -> Set (Int, Int)
f Mv
mv = Mv
mv { frz = f (frz mv) }
mapConstr :: (Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapConstr Set (Int, Int) -> Set (Int, Int)
f Mv
mv = Mv
mv { constr = f (constr mv) }

data Ns = Ns { Ns -> IntSet
coalN :: IS.IntSet, Ns -> IntSet
colN :: IS.IntSet, Ns -> IntSet
spN :: IS.IntSet }

mapCoalN :: (IntSet -> IntSet) -> Ns -> Ns
mapCoalN IntSet -> IntSet
f Ns
ns = Ns
ns { coalN = f (coalN ns) }
mapColN :: (IntSet -> IntSet) -> Ns -> Ns
mapColN IntSet -> IntSet
f Ns
ns = Ns
ns { colN = f (colN ns) }
mapSpN :: (IntSet -> IntSet) -> Ns -> Ns
mapSpN IntSet -> IntSet
f Ns
ns = Ns
ns { spN = f (spN ns) }

data St = St { St -> Movs
mvs :: Movs, St -> Set (Int, Int)
aS :: GS, St -> GL
aL :: GL, St -> Mv
mvS :: Mv, St -> Ns
ɴs :: Ns, St -> IntMap Int
degs :: !(IM.IntMap Int), St -> [Int]
initial :: [Int], St -> Wk
wkls :: Wk, St -> [Int]
stack :: [Int], St -> IntMap Int
alias :: !(IM.IntMap Int) }

mapMv :: (Mv -> Mv) -> St -> St
mapMv Mv -> Mv
f St
st = St
st { mvS = f (mvS st) }; mapWk :: (Wk -> Wk) -> St -> St
mapWk Wk -> Wk
f St
st = St
st { wkls = f (wkls st) }; mapNs :: (Ns -> Ns) -> St -> St
mapNs Ns -> Ns
f St
st = St
st { ɴs = f (ɴs st) }

thread :: [a -> a] -> a -> a
thread :: forall a. [a -> a] -> a -> a
thread = ((a -> a) -> (a -> a) -> a -> a) -> (a -> a) -> [a -> a] -> a -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> a
forall a. a -> a
id

(!:) :: IM.Key -> Int -> GL -> GL
!: :: Int -> Int -> GL -> GL
(!:) Int
k Int
i = (Maybe [Int] -> Maybe [Int]) -> Int -> GL -> GL
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter (\Maybe [Int]
kϵ -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just([Int] -> Maybe [Int]) -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$case Maybe [Int]
kϵ of {Maybe [Int]
Nothing -> [Int
i]; Just [Int]
is -> Int
iInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is}) Int
k

(@!) :: IM.Key -> M -> Movs -> Movs
@! :: Int -> (Int, Int) -> Movs -> Movs
(@!) Int
k (Int, Int)
i = (Maybe (Set (Int, Int)) -> Maybe (Set (Int, Int)))
-> Int -> Movs -> Movs
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter (\Maybe (Set (Int, Int))
kϵ -> Set (Int, Int) -> Maybe (Set (Int, Int))
forall a. a -> Maybe a
Just(Set (Int, Int) -> Maybe (Set (Int, Int)))
-> Set (Int, Int) -> Maybe (Set (Int, Int))
forall a b. (a -> b) -> a -> b
$case Maybe (Set (Int, Int))
kϵ of {Maybe (Set (Int, Int))
Nothing -> (Int, Int) -> Set (Int, Int)
forall a. a -> Set a
S.singleton (Int, Int)
i; Just Set (Int, Int)
is -> (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int, Int)
i Set (Int, Int)
is}) Int
k

(!.) :: Monoid m => IM.IntMap m -> IM.Key -> m
!. :: forall m. Monoid m => IntMap m -> Int -> m
(!.) IntMap m
m Int
k = m -> Int -> IntMap m -> m
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault m
forall a. Monoid a => a
mempty Int
k IntMap m
m

Int
n !* :: Int -> IntMap a -> a
!* IntMap a
d = a -> Int -> IntMap a -> a
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault a
forall a. Bounded a => a
maxBound Int
n IntMap a
d

dec :: IM.Key -> IM.IntMap Int -> IM.IntMap Int
dec :: Int -> IntMap Int -> IntMap Int
dec = (Maybe Int -> Maybe Int) -> Int -> IntMap Int -> IntMap Int
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter (\Maybe Int
k -> case Maybe Int
k of {Maybe Int
Nothing -> Maybe Int
forall a. Maybe a
Nothing;Just Int
d -> Int -> Maybe Int
forall a. a -> Maybe a
Just(Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1})

inc :: IM.Key -> IM.IntMap Int -> IM.IntMap Int
inc :: Int -> IntMap Int -> IntMap Int
inc = (Maybe Int -> Maybe Int) -> Int -> IntMap Int -> IntMap Int
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter (\Maybe Int
k -> case Maybe Int
k of {Maybe Int
Nothing -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1;Just Int
d -> Int -> Maybe Int
forall a. a -> Maybe a
Just(Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1})

emptySt :: IS.IntSet -- ^ Precolored registers
        -> [Int]
        -> St
emptySt :: IntSet -> [Int] -> St
emptySt IntSet
preC [Int]
rs = Movs
-> Set (Int, Int)
-> GL
-> Mv
-> Ns
-> IntMap Int
-> [Int]
-> Wk
-> [Int]
-> IntMap Int
-> St
St Movs
forall a. IntMap a
IM.empty Set (Int, Int)
forall a. Set a
S.empty GL
forall a. IntMap a
IM.empty (Set (Int, Int)
-> Set (Int, Int)
-> Set (Int, Int)
-> Set (Int, Int)
-> Set (Int, Int)
-> Mv
Mv Set (Int, Int)
forall a. Set a
S.empty Set (Int, Int)
forall a. Set a
S.empty Set (Int, Int)
forall a. Set a
S.empty Set (Int, Int)
forall a. Set a
S.empty Set (Int, Int)
forall a. Set a
S.empty) (IntSet -> IntSet -> IntSet -> Ns
Ns IntSet
IS.empty IntSet
IS.empty IntSet
IS.empty) IntMap Int
forall a. IntMap a
IM.empty [Int]
rs (IntSet -> IntSet -> IntSet -> IntSet -> Wk
Wk IntSet
preC IntSet
IS.empty IntSet
IS.empty IntSet
IS.empty) [] IntMap Int
forall a. IntMap a
IM.empty

getIs :: Copointed p => [p Liveness] -> IS.IntSet
getIs :: forall (p :: * -> *). Copointed p => [p Liveness] -> IntSet
getIs = (p Liveness -> IntSet) -> [p Liveness] -> IntSet
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Liveness -> IntSet
g(Liveness -> IntSet)
-> (p Liveness -> Liveness) -> p Liveness -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
.p Liveness -> Liveness
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint) where g :: Liveness -> IntSet
g (Liveness IntSet
is IntSet
os IntSet
_ IntSet
_) = IntSet
isIntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<>IntSet
os

getIFs :: Copointed p => [p Liveness] -> IS.IntSet
getIFs :: forall (p :: * -> *). Copointed p => [p Liveness] -> IntSet
getIFs = (p Liveness -> IntSet) -> [p Liveness] -> IntSet
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Liveness -> IntSet
g(Liveness -> IntSet)
-> (p Liveness -> Liveness) -> p Liveness -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
.p Liveness -> Liveness
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint) where g :: Liveness -> IntSet
g (Liveness IntSet
_ IntSet
_ IntSet
fis IntSet
fos) = IntSet
fisIntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<>IntSet
fos

{-# SCC buildOver #-}
buildOver :: Copointed p => [[p (UD, Liveness, Maybe M)]] -> St -> St
buildOver :: forall (p :: * -> *).
Copointed p =>
[[p (UD, Liveness, Maybe (Int, Int))]] -> St -> St
buildOver [[p (UD, Liveness, Maybe (Int, Int))]]
blocks = [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread [ \St
s -> (IntSet, St) -> St
forall a b. (a, b) -> b
snd ((IntSet, St) -> St) -> (IntSet, St) -> St
forall a b. (a -> b) -> a -> b
$ IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
forall (p :: * -> *).
Copointed p =>
IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
build (Liveness -> IntSet
out ((UD, Liveness, Maybe (Int, Int)) -> Liveness
forall a b c. (a, b, c) -> b
snd3 (p (UD, Liveness, Maybe (Int, Int))
-> (UD, Liveness, Maybe (Int, Int))
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint ([p (UD, Liveness, Maybe (Int, Int))]
-> p (UD, Liveness, Maybe (Int, Int))
forall a. HasCallStack => [a] -> a
last [p (UD, Liveness, Maybe (Int, Int))]
isns)))) St
s ([p (UD, Liveness, Maybe (Int, Int))]
-> [p (UD, Liveness, Maybe (Int, Int))]
forall a. [a] -> [a]
reverse [p (UD, Liveness, Maybe (Int, Int))]
isns) | [p (UD, Liveness, Maybe (Int, Int))]
isns <- [[p (UD, Liveness, Maybe (Int, Int))]]
blocks ]

{-# SCC buildOverF #-}
buildOverF :: Copointed p => [[p (UD, Liveness, Maybe M)]] -> St -> St
buildOverF :: forall (p :: * -> *).
Copointed p =>
[[p (UD, Liveness, Maybe (Int, Int))]] -> St -> St
buildOverF [[p (UD, Liveness, Maybe (Int, Int))]]
blocks = [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread [ \St
s -> (IntSet, St) -> St
forall a b. (a, b) -> b
snd ((IntSet, St) -> St) -> (IntSet, St) -> St
forall a b. (a -> b) -> a -> b
$ IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
forall (p :: * -> *).
Copointed p =>
IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
buildF (Liveness -> IntSet
fout ((UD, Liveness, Maybe (Int, Int)) -> Liveness
forall a b c. (a, b, c) -> b
snd3 (p (UD, Liveness, Maybe (Int, Int))
-> (UD, Liveness, Maybe (Int, Int))
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint ([p (UD, Liveness, Maybe (Int, Int))]
-> p (UD, Liveness, Maybe (Int, Int))
forall a. HasCallStack => [a] -> a
last [p (UD, Liveness, Maybe (Int, Int))]
isns)))) St
s ([p (UD, Liveness, Maybe (Int, Int))]
-> [p (UD, Liveness, Maybe (Int, Int))]
forall a. [a] -> [a]
reverse [p (UD, Liveness, Maybe (Int, Int))]
isns) | [p (UD, Liveness, Maybe (Int, Int))]
isns <- [[p (UD, Liveness, Maybe (Int, Int))]]
blocks ]

alloc :: (Ord reg, Arch arch areg afreg af2, Copointed (arch areg afreg af2))
      => [arch areg afreg af2 (UD, Liveness, Maybe (Int,Int))]
      -> [reg] -- ^ available registers
      -> IS.IntSet -- ^ Precolored @areg@
      -> IM.IntMap reg -- ^ Precolored map
      -> Either IS.IntSet (IM.IntMap reg) -- ^ Map from abs reg. id (temp) to concrete reg.
alloc :: forall reg (arch :: * -> * -> * -> * -> *) areg afreg af2.
(Ord reg, Arch arch areg afreg af2,
 Copointed (arch areg afreg af2)) =>
[arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
-> [reg] -> IntSet -> IntMap reg -> Either IntSet (IntMap reg)
alloc [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
aIsns [reg]
regs IntSet
preC IntMap reg
preCM =
    let st0 :: St
st0 = [[arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]]
-> St -> St
forall (p :: * -> *).
Copointed p =>
[[p (UD, Liveness, Maybe (Int, Int))]] -> St -> St
buildOver (BB arch areg afreg af2 (UD, Liveness, Maybe (Int, Int)) ()
-> [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
forall (arch :: * -> * -> * -> * -> *) reg freg f2reg a b.
BB arch reg freg f2reg a b -> [arch reg freg f2reg a]
unBB(BB arch areg afreg af2 (UD, Liveness, Maybe (Int, Int)) ()
 -> [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))])
-> [BB arch areg afreg af2 (UD, Liveness, Maybe (Int, Int)) ()]
-> [[arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>[arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
-> [BB arch areg afreg af2 (UD, Liveness, Maybe (Int, Int)) ()]
forall a. [arch areg afreg af2 a] -> [BB arch areg afreg af2 a ()]
forall (arch :: * -> * -> * -> * -> *) reg freg f2reg a.
Arch arch reg freg f2reg =>
[arch reg freg f2reg a] -> [BB arch reg freg f2reg a ()]
bb [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
aIsns) (IntSet -> [Int] -> St
emptySt IntSet
preC (IntSet -> [Int]
IS.toList (IntSet -> [Int]) -> IntSet -> [Int]
forall a b. (a -> b) -> a -> b
$ [arch areg afreg af2 Liveness] -> IntSet
forall (p :: * -> *). Copointed p => [p Liveness] -> IntSet
getIs [arch areg afreg af2 Liveness]
nIsns IntSet -> IntSet -> IntSet
IS.\\ IntSet
preC))
        st1 :: St
st1 = Int -> St -> St
mkWorklist Int
ᴋ St
st0
        st2 :: St
st2 = Int -> St -> St
emptyWkl Int
ᴋ St
st1
        (St
st3, IntMap reg
rs) = IntMap reg -> [reg] -> St -> (St, IntMap reg)
forall reg.
Ord reg =>
IntMap reg -> [reg] -> St -> (St, IntMap reg)
assign IntMap reg
preCM [reg]
regs St
st2
        s :: IntSet
s = Ns -> IntSet
spN (St -> Ns
ɴs St
st3)
    in if IntSet -> Bool
IS.null IntSet
s then IntMap reg -> Either IntSet (IntMap reg)
forall a b. b -> Either a b
Right IntMap reg
rs else IntSet -> Either IntSet (IntMap reg)
forall a b. a -> Either a b
Left IntSet
s
    where nIsns :: [arch areg afreg af2 Liveness]
nIsns = ((UD, Liveness, Maybe (Int, Int)) -> Liveness)
-> arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))
-> arch areg afreg af2 Liveness
forall a b.
(a -> b) -> arch areg afreg af2 a -> arch areg afreg af2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UD, Liveness, Maybe (Int, Int)) -> Liveness
forall a b c. (a, b, c) -> b
snd3 (arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))
 -> arch areg afreg af2 Liveness)
-> [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
-> [arch areg afreg af2 Liveness]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
aIsns; ᴋ :: Int
ᴋ = [reg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [reg]
regs

allocF :: (Ord freg, Arch arch areg afreg af2, Copointed (arch areg afreg af2))
       => [arch areg afreg af2 (UD, Liveness, Maybe (Int,Int))]
       -> [freg] -- ^ available registers
       -> IS.IntSet -- ^ Precolored @afreg@
       -> IM.IntMap freg -- ^ Precolored map
       -> Either IS.IntSet (IM.IntMap freg) -- ^ Map from abs freg. id (temp) to concrete reg.
allocF :: forall reg (arch :: * -> * -> * -> * -> *) areg afreg af2.
(Ord reg, Arch arch areg afreg af2,
 Copointed (arch areg afreg af2)) =>
[arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
-> [reg] -> IntSet -> IntMap reg -> Either IntSet (IntMap reg)
allocF [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
aIsns [freg]
regs IntSet
preC IntMap freg
preCM =
    let st0 :: St
st0 = [[arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]]
-> St -> St
forall (p :: * -> *).
Copointed p =>
[[p (UD, Liveness, Maybe (Int, Int))]] -> St -> St
buildOverF (BB arch areg afreg af2 (UD, Liveness, Maybe (Int, Int)) ()
-> [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
forall (arch :: * -> * -> * -> * -> *) reg freg f2reg a b.
BB arch reg freg f2reg a b -> [arch reg freg f2reg a]
unBB(BB arch areg afreg af2 (UD, Liveness, Maybe (Int, Int)) ()
 -> [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))])
-> [BB arch areg afreg af2 (UD, Liveness, Maybe (Int, Int)) ()]
-> [[arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>[arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
-> [BB arch areg afreg af2 (UD, Liveness, Maybe (Int, Int)) ()]
forall a. [arch areg afreg af2 a] -> [BB arch areg afreg af2 a ()]
forall (arch :: * -> * -> * -> * -> *) reg freg f2reg a.
Arch arch reg freg f2reg =>
[arch reg freg f2reg a] -> [BB arch reg freg f2reg a ()]
bb [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
aIsns) (IntSet -> [Int] -> St
emptySt IntSet
preC (IntSet -> [Int]
IS.toList (IntSet -> [Int]) -> IntSet -> [Int]
forall a b. (a -> b) -> a -> b
$ [arch areg afreg af2 Liveness] -> IntSet
forall (p :: * -> *). Copointed p => [p Liveness] -> IntSet
getIFs [arch areg afreg af2 Liveness]
nIsns IntSet -> IntSet -> IntSet
IS.\\ IntSet
preC))
        st1 :: St
st1 = Int -> St -> St
mkWorklist Int
ᴋ St
st0
        st2 :: St
st2 = Int -> St -> St
emptyWkl Int
ᴋ St
st1
        (St
st3, IntMap freg
rs) = IntMap freg -> [freg] -> St -> (St, IntMap freg)
forall reg.
Ord reg =>
IntMap reg -> [reg] -> St -> (St, IntMap reg)
assign IntMap freg
preCM [freg]
regs St
st2
        s :: IntSet
s = Ns -> IntSet
spN (St -> Ns
ɴs St
st3)
    in if IntSet -> Bool
IS.null IntSet
s then IntMap freg -> Either IntSet (IntMap freg)
forall a b. b -> Either a b
Right IntMap freg
rs else IntSet -> Either IntSet (IntMap freg)
forall a b. a -> Either a b
Left IntSet
s
    where nIsns :: [arch areg afreg af2 Liveness]
nIsns = ((UD, Liveness, Maybe (Int, Int)) -> Liveness)
-> arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))
-> arch areg afreg af2 Liveness
forall a b.
(a -> b) -> arch areg afreg af2 a -> arch areg afreg af2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UD, Liveness, Maybe (Int, Int)) -> Liveness
forall a b c. (a, b, c) -> b
snd3 (arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))
 -> arch areg afreg af2 Liveness)
-> [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
-> [arch areg afreg af2 Liveness]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [arch areg afreg af2 (UD, Liveness, Maybe (Int, Int))]
aIsns; ᴋ :: Int
ᴋ = [freg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [freg]
regs

{-# SCC emptyWkl #-}
emptyWkl :: K -> St -> St
emptyWkl :: Int -> St -> St
emptyWkl Int
ᴋ St
s | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ IntSet -> Bool
IS.null (Wk -> IntSet
simp (St -> Wk
wkls St
s)) = Int -> St -> St
emptyWkl Int
ᴋ (Int -> St -> St
simplify Int
ᴋ St
s)
             | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set (Int, Int) -> Bool
forall a. Set a -> Bool
S.null (Mv -> Set (Int, Int)
wl (St -> Mv
mvS St
s)) = Int -> St -> St
emptyWkl Int
ᴋ (Int -> St -> St
coalesce Int
ᴋ St
s)
             | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ IntSet -> Bool
IS.null (Wk -> IntSet
fr (St -> Wk
wkls St
s)) = Int -> St -> St
emptyWkl Int
ᴋ (Int -> St -> St
freeze Int
ᴋ St
s)
             | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ IntSet -> Bool
IS.null (Wk -> IntSet
sp (St -> Wk
wkls St
s)) = Int -> St -> St
emptyWkl Int
ᴋ (Int -> St -> St
sspill Int
ᴋ St
s)
             | Bool
otherwise = St
s

{-# SCC buildF #-}
buildF :: (Copointed p) => IS.IntSet -> St -> [p (UD, Liveness, Maybe M)] -> (IS.IntSet, St)
buildF :: forall (p :: * -> *).
Copointed p =>
IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
buildF IntSet
l St
st [] = (IntSet
l, St
st)
buildF IntSet
l st :: St
st@(St Movs
ml Set (Int, Int)
as GL
al Mv
mv Ns
ns IntMap Int
ds [Int]
i Wk
wk [Int]
s IntMap Int
a) (p (UD, Liveness, Maybe (Int, Int))
isn:[p (UD, Liveness, Maybe (Int, Int))]
isns) | Just (Int, Int)
mIx <- (UD, Liveness, Maybe (Int, Int)) -> Maybe (Int, Int)
forall a b c. (a, b, c) -> c
thd3 (p (UD, Liveness, Maybe (Int, Int))
-> (UD, Liveness, Maybe (Int, Int))
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint p (UD, Liveness, Maybe (Int, Int))
isn) =
    let ca :: UD
ca = (UD, Liveness, Maybe (Int, Int)) -> UD
forall a b c. (a, b, c) -> a
fst3 (p (UD, Liveness, Maybe (Int, Int))
-> (UD, Liveness, Maybe (Int, Int))
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint p (UD, Liveness, Maybe (Int, Int))
isn)
        u :: IntSet
u = UD -> IntSet
usesFNode UD
ca; d :: IntSet
d = UD -> IntSet
defsFNode UD
ca
        lm :: IntSet
lm = IntSet
l IntSet -> IntSet -> IntSet
IS.\\ IntSet
u
        ml' :: Movs
ml' = [Movs -> Movs] -> Movs -> Movs
forall a. [a -> a] -> a -> a
thread [ Int
kϵ Int -> (Int, Int) -> Movs -> Movs
@! (Int, Int)
mIx | Int
kϵ <- IntSet -> [Int]
IS.toList (IntSet
u IntSet -> IntSet -> IntSet
`IS.union` IntSet
d) ] Movs
ml
        le :: IntSet
le = IntSet
lm IntSet -> IntSet -> IntSet
`IS.union` IntSet
d
        st' :: St
st' = Movs
-> Set (Int, Int)
-> GL
-> Mv
-> Ns
-> IntMap Int
-> [Int]
-> Wk
-> [Int]
-> IntMap Int
-> St
St Movs
ml' Set (Int, Int)
as GL
al ((Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapWl ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int, Int)
mIx) Mv
mv) Ns
ns IntMap Int
ds [Int]
i Wk
wk [Int]
s IntMap Int
a
        st'' :: St
st'' = [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread [ Int -> Int -> St -> St
addEdge Int
lϵ Int
dϵ | Int
lϵ <- IntSet -> [Int]
IS.toList IntSet
le, Int
dϵ <- IntSet -> [Int]
IS.toList IntSet
d ] St
st'
        l' :: IntSet
l' = IntSet
u IntSet -> IntSet -> IntSet
`IS.union` (IntSet
lm IntSet -> IntSet -> IntSet
IS.\\ IntSet
d)
    in IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
forall (p :: * -> *).
Copointed p =>
IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
buildF IntSet
l' St
st'' [p (UD, Liveness, Maybe (Int, Int))]
isns
                                  | Bool
otherwise =
    let ca :: UD
ca = (UD, Liveness, Maybe (Int, Int)) -> UD
forall a b c. (a, b, c) -> a
fst3 (p (UD, Liveness, Maybe (Int, Int))
-> (UD, Liveness, Maybe (Int, Int))
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint p (UD, Liveness, Maybe (Int, Int))
isn)
        u :: IntSet
u = UD -> IntSet
usesFNode UD
ca; d :: IntSet
d = UD -> IntSet
defsFNode UD
ca
        le :: IntSet
le = IntSet
l IntSet -> IntSet -> IntSet
`IS.union` IntSet
d
        st'' :: St
st'' = [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread [ Int -> Int -> St -> St
addEdge Int
lϵ Int
dϵ | Int
lϵ <- IntSet -> [Int]
IS.toList IntSet
le, Int
dϵ <- IntSet -> [Int]
IS.toList IntSet
d ] St
st
        l' :: IntSet
l' = IntSet
u IntSet -> IntSet -> IntSet
`IS.union` (IntSet
l IntSet -> IntSet -> IntSet
IS.\\ IntSet
d)
    in IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
forall (p :: * -> *).
Copointed p =>
IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
buildF IntSet
l' St
st'' [p (UD, Liveness, Maybe (Int, Int))]
isns

{-# SCC build #-}
-- | To be called in reverse order
build :: (Copointed p)
      => IS.IntSet -- ^ Live-out for the block
      -> St
      -> [p (UD, Liveness, Maybe M)]
      -> (IS.IntSet, St)
build :: forall (p :: * -> *).
Copointed p =>
IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
build IntSet
l St
st [] = (IntSet
l, St
st)
build IntSet
l st :: St
st@(St Movs
ml Set (Int, Int)
as GL
al Mv
mv Ns
ns IntMap Int
ds [Int]
i Wk
wk [Int]
s IntMap Int
a) (p (UD, Liveness, Maybe (Int, Int))
isn:[p (UD, Liveness, Maybe (Int, Int))]
isns) | Just (Int, Int)
mIx <- (UD, Liveness, Maybe (Int, Int)) -> Maybe (Int, Int)
forall a b c. (a, b, c) -> c
thd3 (p (UD, Liveness, Maybe (Int, Int))
-> (UD, Liveness, Maybe (Int, Int))
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint p (UD, Liveness, Maybe (Int, Int))
isn) =
    let ca :: UD
ca = (UD, Liveness, Maybe (Int, Int)) -> UD
forall a b c. (a, b, c) -> a
fst3 (p (UD, Liveness, Maybe (Int, Int))
-> (UD, Liveness, Maybe (Int, Int))
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint p (UD, Liveness, Maybe (Int, Int))
isn)
        u :: IntSet
u = UD -> IntSet
usesNode UD
ca; d :: IntSet
d = UD -> IntSet
defsNode UD
ca
        lm :: IntSet
lm = IntSet
l IntSet -> IntSet -> IntSet
IS.\\ IntSet
u
        ml' :: Movs
ml' = [Movs -> Movs] -> Movs -> Movs
forall a. [a -> a] -> a -> a
thread [ Int
kϵ Int -> (Int, Int) -> Movs -> Movs
@! (Int, Int)
mIx | Int
kϵ <- IntSet -> [Int]
IS.toList (IntSet
u IntSet -> IntSet -> IntSet
`IS.union` IntSet
d) ] Movs
ml
        le :: IntSet
le = IntSet
lm IntSet -> IntSet -> IntSet
`IS.union` IntSet
d
        st' :: St
st' = Movs
-> Set (Int, Int)
-> GL
-> Mv
-> Ns
-> IntMap Int
-> [Int]
-> Wk
-> [Int]
-> IntMap Int
-> St
St Movs
ml' Set (Int, Int)
as GL
al ((Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapWl ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int, Int)
mIx) Mv
mv) Ns
ns IntMap Int
ds [Int]
i Wk
wk [Int]
s IntMap Int
a
        st'' :: St
st'' = [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread [ Int -> Int -> St -> St
addEdge Int
lϵ Int
dϵ | Int
lϵ <- IntSet -> [Int]
IS.toList IntSet
le, Int
dϵ <- IntSet -> [Int]
IS.toList IntSet
d ] St
st'
        l' :: IntSet
l' = IntSet
u IntSet -> IntSet -> IntSet
`IS.union` (IntSet
lm IntSet -> IntSet -> IntSet
IS.\\ IntSet
d)
    in IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
forall (p :: * -> *).
Copointed p =>
IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
build IntSet
l' St
st'' [p (UD, Liveness, Maybe (Int, Int))]
isns
                                  | Bool
otherwise =
    let ca :: UD
ca = (UD, Liveness, Maybe (Int, Int)) -> UD
forall a b c. (a, b, c) -> a
fst3 (p (UD, Liveness, Maybe (Int, Int))
-> (UD, Liveness, Maybe (Int, Int))
forall a. p a -> a
forall (p :: * -> *) a. Copointed p => p a -> a
copoint p (UD, Liveness, Maybe (Int, Int))
isn)
        u :: IntSet
u = UD -> IntSet
usesNode UD
ca
        d :: IntSet
d = UD -> IntSet
defsNode UD
ca
        le :: IntSet
le = IntSet
l IntSet -> IntSet -> IntSet
`IS.union` IntSet
d
        st'' :: St
st'' = [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread [ Int -> Int -> St -> St
addEdge Int
lϵ Int
dϵ | Int
lϵ <- IntSet -> [Int]
IS.toList IntSet
le, Int
dϵ <- IntSet -> [Int]
IS.toList IntSet
d ] St
st
        l' :: IntSet
l' = IntSet
u IntSet -> IntSet -> IntSet
`IS.union` (IntSet
l IntSet -> IntSet -> IntSet
IS.\\ IntSet
d)
    in IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
forall (p :: * -> *).
Copointed p =>
IntSet
-> St -> [p (UD, Liveness, Maybe (Int, Int))] -> (IntSet, St)
build IntSet
l' St
st'' [p (UD, Liveness, Maybe (Int, Int))]
isns

{-# SCC addEdge #-}
addEdge :: Int -> Int -> St -> St
addEdge :: Int -> Int -> St -> St
addEdge Int
u Int
v st :: St
st@(St Movs
ml Set (Int, Int)
as GL
al Mv
mv Ns
ns IntMap Int
ds [Int]
i Wk
wk [Int]
s IntMap Int
a) =
    if (Int
u, Int
v) (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set (Int, Int)
as Bool -> Bool -> Bool
&& Int
u Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
v
        then
            let as' :: Set (Int, Int)
as' = (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int
u,Int
v) (Set (Int, Int) -> Set (Int, Int))
-> Set (Int, Int) -> Set (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int
v,Int
u) Set (Int, Int)
as
                preC :: IntSet
preC = Wk -> IntSet
pre Wk
wk
                uC :: Bool
uC = Int
u Int -> IntSet -> Bool
`IS.notMember` IntSet
preC
                vC :: Bool
vC = Int
v Int -> IntSet -> Bool
`IS.notMember` IntSet
preC
                al' :: GL
al' = (if Bool
uC then Int
u Int -> Int -> GL -> GL
!: Int
v else GL -> GL
forall a. a -> a
id)(GL -> GL) -> GL -> GL
forall a b. (a -> b) -> a -> b
$(if Bool
vC then Int
v Int -> Int -> GL -> GL
!: Int
u else GL -> GL
forall a. a -> a
id) GL
al
                ds' :: IntMap Int
ds' = (if Bool
uC then Int -> IntMap Int -> IntMap Int
inc Int
u else IntMap Int -> IntMap Int
forall a. a -> a
id)(IntMap Int -> IntMap Int) -> IntMap Int -> IntMap Int
forall a b. (a -> b) -> a -> b
$(if Bool
vC then Int -> IntMap Int -> IntMap Int
inc Int
v else IntMap Int -> IntMap Int
forall a. a -> a
id) IntMap Int
ds
            in Movs
-> Set (Int, Int)
-> GL
-> Mv
-> Ns
-> IntMap Int
-> [Int]
-> Wk
-> [Int]
-> IntMap Int
-> St
St Movs
ml Set (Int, Int)
as' GL
al' Mv
mv Ns
ns IntMap Int
ds' [Int]
i Wk
wk [Int]
s IntMap Int
a
        else St
st

{-# SCC mkWorklist #-}
mkWorklist :: K -> St -> St
mkWorklist :: Int -> St -> St
mkWorklist Int
ᴋ st :: St
st@(St Movs
_ Set (Int, Int)
_ GL
_ Mv
_ Ns
_ IntMap Int
ds [Int]
i Wk
wk [Int]
_ IntMap Int
_) =
    let wk' :: Wk
wk' = [Wk -> Wk] -> Wk -> Wk
forall a. [a -> a] -> a -> a
thread [ (case () of { ()
_ | Int
n Int -> IntMap Int -> Int
forall {a}. Bounded a => Int -> IntMap a -> a
!* IntMap Int
ds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
ᴋ -> (IntSet -> IntSet) -> Wk -> Wk
mapSp; ()
_ | Int -> St -> Bool
isMR Int
n St
st -> (IntSet -> IntSet) -> Wk -> Wk
mapFr; ()
_-> (IntSet -> IntSet) -> Wk -> Wk
mapSimp}) (Int -> IntSet -> IntSet
IS.insert Int
n) | Int
n <- [Int]
i ] Wk
wk
    in St
st { initial = [], wkls = wk' }

-- same for xmm0, r15
-- ᴋ = 16

isMR :: Int -> St -> Bool
isMR :: Int -> St -> Bool
isMR Int
i St
st = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set (Int, Int) -> Bool
forall a. Set a -> Bool
S.null (Int -> St -> Set (Int, Int)
nodeMoves Int
i St
st)

{-# SCC nodeMoves #-}
nodeMoves :: Int -> St -> MS
nodeMoves :: Int -> St -> Set (Int, Int)
nodeMoves Int
n (St Movs
ml Set (Int, Int)
_ GL
_ Mv
mv Ns
_ IntMap Int
_ [Int]
_ Wk
_ [Int]
_ IntMap Int
_) = Movs
ml Movs -> Int -> Set (Int, Int)
forall m. Monoid m => IntMap m -> Int -> m
!. Int
n Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` (Mv -> Set (Int, Int)
actv Mv
mv Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Mv -> Set (Int, Int)
wl Mv
mv)

{-# SCC simplify #-}
simplify :: K -> St -> St
simplify :: Int -> St -> St
simplify Int
ᴋ s :: St
s@(St Movs
_ Set (Int, Int)
_ GL
_ Mv
_ Ns
_ IntMap Int
_ [Int]
_ wk :: Wk
wk@(Wk IntSet
_ IntSet
_ IntSet
_ IntSet
stϵ) [Int]
st IntMap Int
_) | Just (Int
n,IntSet
ns) <- IntSet -> Maybe (Int, IntSet)
IS.minView IntSet
stϵ =
    let s' :: St
s' = St
s { wkls = wk { simp = ns }, stack = n:st }
    in [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread [ Int -> Int -> St -> St
ddg Int
ᴋ Int
m | Int
m <- Int -> St -> [Int]
adj Int
n St
s' ] St
s'
                                                       | Bool
otherwise = St
s

{-# SCC ddg #-}
-- decrement degree
ddg :: K -> Int -> St -> St
ddg :: Int -> Int -> St -> St
ddg Int
ᴋ Int
m St
s | Int
m Int -> IntSet -> Bool
`IS.member` Wk -> IntSet
pre (St -> Wk
wkls St
s) = St
s
        | Bool
otherwise =
    let d :: IntMap Int
d = St -> IntMap Int
degs St
s; s' :: St
s' = St
s { degs = dec m d }
    in if IntMap Int
d IntMap Int -> Int -> Int
forall a. IntMap a -> Int -> a
IM.! Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ᴋ
        then let s'' :: St
s'' = [Int] -> St -> St
enaMv (Int
mInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:Int -> St -> [Int]
adj Int
m St
s) St
s'
             in (Wk -> Wk) -> St -> St
mapWk ((IntSet -> IntSet) -> Wk -> Wk
mapSp (Int -> IntSet -> IntSet
IS.delete Int
m)(Wk -> Wk) -> (Wk -> Wk) -> Wk -> Wk
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(if Int -> St -> Bool
isMR Int
m St
s'' then (IntSet -> IntSet) -> Wk -> Wk
mapFr else (IntSet -> IntSet) -> Wk -> Wk
mapSimp) (Int -> IntSet -> IntSet
IS.insert Int
m)) St
s''
        else St
s'

-- enable moves
enaMv :: [Int] -> St -> St
enaMv :: [Int] -> St -> St
enaMv [Int]
ns = [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread ((Int -> St -> St) -> [Int] -> [St -> St]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> St -> St
g [Int]
ns) where
    g :: Int -> St -> St
g Int
n St
st = let ms :: [(Int, Int)]
ms = Set (Int, Int) -> [(Int, Int)]
forall a. Set a -> [a]
S.toList (Int -> St -> Set (Int, Int)
nodeMoves Int
n St
st) in [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread (((Int, Int) -> St -> St) -> [(Int, Int)] -> [St -> St]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> St -> St
h [(Int, Int)]
ms) St
st
        where h :: (Int, Int) -> St -> St
h (Int, Int)
m St
stϵ | (Int, Int)
m (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Mv -> Set (Int, Int)
actv(St -> Mv
mvS St
stϵ) = (Mv -> Mv) -> St -> St
mapMv ((Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapWl ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int, Int)
m) (Mv -> Mv) -> (Mv -> Mv) -> Mv -> Mv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapActv ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.delete (Int, Int)
m)) St
st
                      | Bool
otherwise = St
st

{-# SCC addWkl #-}
addWkl :: K -> Int -> St -> St
addWkl :: Int -> Int -> St -> St
addWkl Int
ᴋ Int
u St
st | Int
u Int -> IntSet -> Bool
`IS.notMember` Wk -> IntSet
pre (St -> Wk
wkls St
st) Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> St -> Bool
isMR Int
u St
st) Bool -> Bool -> Bool
&& Int
u Int -> IntMap Int -> Int
forall {a}. Bounded a => Int -> IntMap a -> a
!* St -> IntMap Int
degs St
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ᴋ = (Wk -> Wk) -> St -> St
mapWk ((IntSet -> IntSet) -> Wk -> Wk
mapFr (Int -> IntSet -> IntSet
IS.delete Int
u) (Wk -> Wk) -> (Wk -> Wk) -> Wk -> Wk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntSet -> IntSet) -> Wk -> Wk
mapSimp (Int -> IntSet -> IntSet
IS.insert Int
u)) St
st
              | Bool
otherwise = St
st

{-# SCC ok #-}
ok :: K -> Int -> Int -> St -> Bool
ok :: Int -> Int -> Int -> St -> Bool
ok Int
ᴋ Int
t Int
r St
s = Int
t Int -> IntSet -> Bool
`IS.member` Wk -> IntSet
pre (St -> Wk
wkls St
s) Bool -> Bool -> Bool
|| St -> IntMap Int
degs St
s IntMap Int -> Int -> Int
forall a. IntMap a -> Int -> a
IM.! Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ᴋ Bool -> Bool -> Bool
|| (Int
t,Int
r) (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` St -> Set (Int, Int)
aS St
s

{-# SCC conserv #-}
conserv :: K -> [Int] -> St -> Bool
conserv :: Int -> [Int] -> St -> Bool
conserv Int
ᴋ [Int]
is St
s =
    let d :: IntMap Int
d = St -> IntMap Int
degs St
s
        k :: Int
k = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Int
n -> (Int
n Int -> IntMap Int -> Int
forall {a}. Bounded a => Int -> IntMap a -> a
!* IntMap Int
d)Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
ᴋ) [Int]
is)
    in Int
kInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
ᴋ

{-# SCC getAlias #-}
getAlias :: Int -> St -> Int
getAlias :: Int -> St -> Int
getAlias Int
i St
s = case Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i (St -> IntMap Int
alias St
s) of {Just Int
i' -> Int -> St -> Int
getAlias Int
i' St
s; Maybe Int
Nothing -> Int
i}

{-# SCC combine #-}
combine :: K -> Int -> Int -> St -> St
combine :: Int -> Int -> Int -> St -> St
combine Int
ᴋ Int
u Int
v St
st =
    let st0 :: St
st0 = (Wk -> Wk) -> St -> St
mapWk (\(Wk IntSet
p IntSet
s IntSet
f IntSet
sm) -> if Int
v Int -> IntSet -> Bool
`IS.member` IntSet
f then IntSet -> IntSet -> IntSet -> IntSet -> Wk
Wk IntSet
p IntSet
s (Int -> IntSet -> IntSet
IS.delete Int
v IntSet
f) IntSet
sm else IntSet -> IntSet -> IntSet -> IntSet -> Wk
Wk IntSet
p (Int -> IntSet -> IntSet
IS.delete Int
v IntSet
s) IntSet
f IntSet
sm) St
st
        st1 :: St
st1 = (Ns -> Ns) -> St -> St
mapNs ((IntSet -> IntSet) -> Ns -> Ns
mapCoalN (Int -> IntSet -> IntSet
IS.insert Int
v)) St
st0
        st2 :: St
st2 = St
st1 { alias = IM.insert v u (alias st1) }
        -- https://github.com/sunchao/tiger/blob/d083a354987b7f1fe23f7065ab0c19c714e78cc4/color.sml#L265
        st3 :: St
st3 = let m :: Movs
m = St -> Movs
mvs St
st2 -- default to S.empty if we haven't filled it in
                  mvu :: Set (Int, Int)
mvu = Movs
m Movs -> Int -> Set (Int, Int)
forall m. Monoid m => IntMap m -> Int -> m
!. Int
u; mvv :: Set (Int, Int)
mvv = Movs
m Movs -> Int -> Set (Int, Int)
forall m. Monoid m => IntMap m -> Int -> m
!. Int
v in St
st2 { mvs = IM.insert u (mvu `S.union` mvv) m }
        st4 :: St
st4 = [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread [ Int -> Int -> St -> St
ddg Int
ᴋ Int
t(St -> St) -> (St -> St) -> St -> St
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Int -> St -> St
addEdge Int
t Int
u | Int
t <- Int -> St -> [Int]
adj Int
v St
st2 ] St
st3
    in if Int
u Int -> IntSet -> Bool
`IS.member` Wk -> IntSet
fr(St -> Wk
wkls St
st3) Bool -> Bool -> Bool
&& Int
u Int -> IntMap Int -> Int
forall {a}. Bounded a => Int -> IntMap a -> a
!* St -> IntMap Int
degs St
st4 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
ᴋ then (Wk -> Wk) -> St -> St
mapWk(\(Wk IntSet
p IntSet
s IntSet
f IntSet
sm) -> IntSet -> IntSet -> IntSet -> IntSet -> Wk
Wk IntSet
p (Int -> IntSet -> IntSet
IS.insert Int
u IntSet
s) (Int -> IntSet -> IntSet
IS.delete Int
u IntSet
f) IntSet
sm) St
st4 else St
st4

freeze :: K -> St -> St
freeze :: Int -> St -> St
freeze Int
ᴋ St
s | Just (Int
u, IntSet
_) <- IntSet -> Maybe (Int, IntSet)
IS.minView (Wk -> IntSet
fr(Wk -> IntSet) -> Wk -> IntSet
forall a b. (a -> b) -> a -> b
$St -> Wk
wkls St
s) =
    let s0 :: St
s0 = (Wk -> Wk) -> St -> St
mapWk ((IntSet -> IntSet) -> Wk -> Wk
mapFr (Int -> IntSet -> IntSet
IS.delete Int
u)(Wk -> Wk) -> (Wk -> Wk) -> Wk -> Wk
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(IntSet -> IntSet) -> Wk -> Wk
mapSimp (Int -> IntSet -> IntSet
IS.insert Int
u)) St
s in Int -> Int -> St -> St
freezeMoves Int
ᴋ Int
u St
s0

{-# SCC freezeMoves #-}
freezeMoves :: K -> Int -> St -> St
freezeMoves :: Int -> Int -> St -> St
freezeMoves Int
ᴋ Int
u St
st = [St -> St] -> St -> St
forall a. [a -> a] -> a -> a
thread (((Int, Int) -> St -> St) -> [(Int, Int)] -> [St -> St]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> St -> St
g (Set (Int, Int) -> [(Int, Int)]
forall a. Set a -> [a]
S.toList(Set (Int, Int) -> [(Int, Int)]) -> Set (Int, Int) -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$Int -> St -> Set (Int, Int)
nodeMoves Int
u St
st)) St
st where
    g :: (Int, Int) -> St -> St
g m :: (Int, Int)
m@(Int
x, Int
y) St
s =
        let y' :: Int
y' = Int -> St -> Int
getAlias Int
y St
s; v :: Int
v = if Int
y' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> St -> Int
getAlias Int
u St
s then Int -> St -> Int
getAlias Int
x St
s else Int
y'
            st0 :: St
st0 = (Mv -> Mv) -> St -> St
mapMv ((Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapActv ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.delete (Int, Int)
m)(Mv -> Mv) -> (Mv -> Mv) -> Mv -> Mv
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapFrz ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int, Int)
m)) St
s
        in if Set (Int, Int) -> Bool
forall a. Set a -> Bool
S.null (Int -> St -> Set (Int, Int)
nodeMoves Int
v St
st0) Bool -> Bool -> Bool
&& Int
v Int -> IntMap Int -> Int
forall {a}. Bounded a => Int -> IntMap a -> a
!* St -> IntMap Int
degs St
st0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ᴋ
            then (Wk -> Wk) -> St -> St
mapWk ((IntSet -> IntSet) -> Wk -> Wk
mapFr (Int -> IntSet -> IntSet
IS.delete Int
v)(Wk -> Wk) -> (Wk -> Wk) -> Wk -> Wk
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(IntSet -> IntSet) -> Wk -> Wk
mapSimp (Int -> IntSet -> IntSet
IS.insert Int
v)) St
st0
            else St
st0

{-# SCC adj #-}
adj :: Int -> St -> [Int]
adj :: Int -> St -> [Int]
adj Int
n St
s = St -> GL
aL St
s GL -> Int -> [Int]
forall m. Monoid m => IntMap m -> Int -> m
!. Int
n [Int] -> IntSet -> [Int]
∖ ([Int] -> IntSet
IS.fromList (St -> [Int]
stack St
s) IntSet -> IntSet -> IntSet
forall a. Semigroup a => a -> a -> a
<> Ns -> IntSet
coalN (St -> Ns
ɴs St
s))

(∖) :: [Int] -> IS.IntSet -> [Int]
∖ :: [Int] -> IntSet -> [Int]
(∖) [Int]
x IntSet
yϵ = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> IntSet -> Bool
`IS.notMember` IntSet
yϵ) [Int]
x

dSet :: Ord reg => [reg] -> [reg] -> [reg]
dSet :: forall reg. Ord reg => [reg] -> [reg] -> [reg]
dSet [reg]
x [reg]
ys = (reg -> Bool) -> [reg] -> [reg]
forall a. (a -> Bool) -> [a] -> [a]
filter (reg -> Set reg -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set reg
yϵ) [reg]
x where yϵ :: Set reg
yϵ = [reg] -> Set reg
forall a. Ord a => [a] -> Set a
S.fromList [reg]
ys

{-# SCC coalesce #-}
coalesce :: K -> St -> St
coalesce :: Int -> St -> St
coalesce Int
ᴋ St
s | Just (m :: (Int, Int)
m@(Int
x,Int
y), Set (Int, Int)
nWl) <- Set (Int, Int) -> Maybe ((Int, Int), Set (Int, Int))
forall a. Set a -> Maybe (a, Set a)
S.minView (Mv -> Set (Int, Int)
wl(Mv -> Set (Int, Int)) -> Mv -> Set (Int, Int)
forall a b. (a -> b) -> a -> b
$St -> Mv
mvS St
s) =
    let y' :: Int
y' = Int -> St -> Int
getAlias Int
y St
s
        preS :: IntSet
preS = Wk -> IntSet
pre (St -> Wk
wkls St
s)
        (Int
u, Int
v) = if Int
y' Int -> IntSet -> Bool
`IS.member` IntSet
preS then (Int
y',Int
x') else (Int
x',Int
y') where x' :: Int
x' = Int -> St -> Int
getAlias Int
x St
s
        s0 :: St
s0 = (Mv -> Mv) -> St -> St
mapMv (\Mv
mv -> Mv
mv { wl = nWl }) St
s
    in case () of
        ()
_ | Int
u Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v -> Int -> Int -> St -> St
addWkl Int
ᴋ Int
u (St -> St) -> St -> St
forall a b. (a -> b) -> a -> b
$ (Mv -> Mv) -> St -> St
mapMv ((Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapCoal ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int, Int)
m)) St
s0
          | Int
v Int -> IntSet -> Bool
`IS.member` IntSet
preS Bool -> Bool -> Bool
|| (Int
u,Int
v) (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` St -> Set (Int, Int)
aS St
s0 -> Int -> Int -> St -> St
addWkl Int
ᴋ Int
v (St -> St) -> St -> St
forall a b. (a -> b) -> a -> b
$ Int -> Int -> St -> St
addWkl Int
ᴋ Int
u (St -> St) -> St -> St
forall a b. (a -> b) -> a -> b
$ (Mv -> Mv) -> St -> St
mapMv ((Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapConstr ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int, Int)
m)) St
s0
          | let av :: [Int]
av = Int -> St -> [Int]
adj Int
v St
s0 in if Int
u Int -> IntSet -> Bool
`IS.member` IntSet
preS then (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Int
t -> Int -> Int -> Int -> St -> Bool
ok Int
ᴋ Int
t Int
u St
s0) [Int]
av else Int -> [Int] -> St -> Bool
conserv Int
ᴋ (Int -> St -> [Int]
adj Int
u St
s0 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
av) St
s0 ->
              Int -> Int -> St -> St
addWkl Int
ᴋ Int
u (St -> St) -> St -> St
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> St -> St
combine Int
ᴋ Int
u Int
v (St -> St) -> St -> St
forall a b. (a -> b) -> a -> b
$ (Mv -> Mv) -> St -> St
mapMv ((Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapCoal ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int, Int)
m)) St
s0
          | Bool
otherwise -> (Mv -> Mv) -> St -> St
mapMv ((Set (Int, Int) -> Set (Int, Int)) -> Mv -> Mv
mapActv ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Int, Int)
m)) St
s0

sspill :: K -> St -> St
sspill :: Int -> St -> St
sspill Int
ᴋ St
s | Just (Int
m, IntSet
nSp) <- IntSet -> Maybe (Int, IntSet)
IS.minView (Wk -> IntSet
sp(Wk -> IntSet) -> Wk -> IntSet
forall a b. (a -> b) -> a -> b
$St -> Wk
wkls St
s) = Int -> Int -> St -> St
freezeMoves Int
ᴋ Int
m (St -> St) -> St -> St
forall a b. (a -> b) -> a -> b
$ (Wk -> Wk) -> St -> St
mapWk ((IntSet -> IntSet) -> Wk -> Wk
mapSimp (Int -> IntSet -> IntSet
IS.insert Int
m)(Wk -> Wk) -> (Wk -> Wk) -> Wk -> Wk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Wk
wk -> Wk
wk { sp = nSp }) St
s

{-# SCC assign #-}
assign :: (Ord reg) => IM.IntMap reg -> [reg] -> St -> (St, IM.IntMap reg)
assign :: forall reg.
Ord reg =>
IntMap reg -> [reg] -> St -> (St, IntMap reg)
assign IntMap reg
iC [reg]
colors St
s = (St, Any, IntMap reg) -> (St, IntMap reg)
forall {a} {b} {b}. (a, b, b) -> (a, b)
snip ((St, Any, IntMap reg) -> (St, IntMap reg))
-> (St, Any, IntMap reg) -> (St, IntMap reg)
forall a b. (a -> b) -> a -> b
$ (St, [reg], IntMap reg) -> (St, Any, IntMap reg)
forall {b}. (St, [reg], IntMap reg) -> (St, b, IntMap reg)
go (St
s, [reg]
colors, IntMap reg
iC) where
    snip :: (a, b, b) -> (a, b)
snip (a
x, b
_, b
z) = (a
x, b
z)
    go :: (St, [reg], IntMap reg) -> (St, b, IntMap reg)
go (sϵ :: St
sϵ@(St Movs
_ Set (Int, Int)
_ GL
_ Mv
_ (Ns IntSet
ns IntSet
_ IntSet
_) IntMap Int
_ [Int]
_ Wk
_ [] IntMap Int
_), [reg]
_, IntMap reg
c) = (St
sϵ, b
forall a. HasCallStack => a
undefined, [IntMap reg -> IntMap reg] -> IntMap reg -> IntMap reg
forall a. [a -> a] -> a -> a
thread [ Int -> reg -> IntMap reg -> IntMap reg
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
n (IntMap reg
c IntMap reg -> Int -> reg
forall a. IntMap a -> Int -> a
IM.! Int -> St -> Int
getAlias Int
n St
sϵ) | Int
n <- IntSet -> [Int]
IS.toList IntSet
ns ] IntMap reg
c)
    go (sϵ :: St
sϵ@(St Movs
_ Set (Int, Int)
_ GL
al Mv
_ Ns
_ IntMap Int
_ [Int]
_ Wk
_ (Int
n:[Int]
ns) IntMap Int
_), [reg]
okϵ, IntMap reg
cs) =
        let ok0 :: [reg]
ok0 = [reg]
okϵ [reg] -> [reg] -> [reg]
forall reg. Ord reg => [reg] -> [reg] -> [reg]
`dSet` [ IntMap reg
cs IntMap reg -> Int -> reg
forall a. IntMap a -> Int -> a
IM.! Int -> St -> Int
getAlias Int
w St
sϵ | Int
w <- GL
al GL -> Int -> [Int]
forall m. Monoid m => IntMap m -> Int -> m
!. Int
n, Int -> St -> Int
getAlias Int
w St
sϵ Int -> IntSet -> Bool
`IS.member` (Ns -> IntSet
colN (St -> Ns
ɴs St
sϵ) IntSet -> IntSet -> IntSet
`IS.union` Wk -> IntSet
pre (St -> Wk
wkls St
sϵ)) ]
            s0 :: St
s0 = St
sϵ { stack = ns }
            (St
s1, IntMap reg
cs0) =
                case [reg]
ok0 of
                    reg
c:[reg]
_ -> ((Ns -> Ns) -> St -> St
mapNs ((IntSet -> IntSet) -> Ns -> Ns
mapColN (Int -> IntSet -> IntSet
IS.insert Int
n)) St
s0, Int -> reg -> IntMap reg -> IntMap reg
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
n reg
c IntMap reg
cs)
                    [reg]
_   -> ((Ns -> Ns) -> St -> St
mapNs ((IntSet -> IntSet) -> Ns -> Ns
mapSpN (Int -> IntSet -> IntSet
IS.insert Int
n)) St
s0, IntMap reg
cs)
        in (St, [reg], IntMap reg) -> (St, b, IntMap reg)
go (St
s1, [reg]
colors, IntMap reg
cs0)