module Asm.X86.P ( gallocFrame, gallocOn ) where

import           Asm.Ar.P
import           Asm.G
import           Asm.LI
import           Asm.X86
import           Asm.X86.Frame
import           Asm.X86.Sp
import           Data.Int      (Int64)
import qualified Data.IntMap   as IM
import qualified Data.Set      as S

-- TODO: don't bother re-analyzing if no Calls
gallocFrame :: Int -- ^ int supply for spilling
            -> [X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()]
gallocFrame :: Int -> [X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()]
gallocFrame Int
u = [X86 X86Reg FX86Reg Live] -> [X86 X86Reg FX86Reg ()]
frameC ([X86 X86Reg FX86Reg Live] -> [X86 X86Reg FX86Reg ()])
-> ([X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg Live])
-> [X86 AbsReg FAbsReg ()]
-> [X86 X86Reg FX86Reg ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [X86 X86Reg FX86Reg ()] -> [X86 X86Reg FX86Reg Live]
forall (arch :: * -> * -> * -> *) reg freg.
(Arch arch reg freg, Copointed (arch reg freg)) =>
[arch reg freg ()] -> [arch reg freg Live]
mkIntervals ([X86 X86Reg FX86Reg ()] -> [X86 X86Reg FX86Reg Live])
-> ([X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()])
-> [X86 AbsReg FAbsReg ()]
-> [X86 X86Reg FX86Reg Live]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()]
galloc Int
u

{-# SCC galloc #-}
galloc :: Int -> [X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()]
galloc :: Int -> [X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()]
galloc Int
u [X86 AbsReg FAbsReg ()]
isns = Set X86Reg -> [X86 X86Reg FX86Reg ()] -> [X86 X86Reg FX86Reg ()]
frame Set X86Reg
clob'd ((X86 AbsReg FAbsReg () -> X86 X86Reg FX86Reg ())
-> [X86 AbsReg FAbsReg ()] -> [X86 X86Reg FX86Reg ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsReg -> X86Reg)
-> X86 AbsReg FX86Reg () -> X86 X86Reg FX86Reg ()
forall areg reg afreg a.
(areg -> reg) -> X86 areg afreg a -> X86 reg afreg a
mapR ((IntMap X86Reg
regs IntMap X86Reg -> Int -> X86Reg
forall a. IntMap a -> Int -> a
IM.!)(Int -> X86Reg) -> (AbsReg -> Int) -> AbsReg -> X86Reg
forall b c a. (b -> c) -> (a -> b) -> a -> c
.AbsReg -> Int
toInt)(X86 AbsReg FX86Reg () -> X86 X86Reg FX86Reg ())
-> (X86 AbsReg FAbsReg () -> X86 AbsReg FX86Reg ())
-> X86 AbsReg FAbsReg ()
-> X86 X86Reg FX86Reg ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(FAbsReg -> FX86Reg)
-> X86 AbsReg FAbsReg () -> X86 AbsReg FX86Reg ()
forall afreg freg areg a.
(afreg -> freg) -> X86 areg afreg a -> X86 areg freg a
mapFR ((IntMap FX86Reg
fregs IntMap FX86Reg -> Int -> FX86Reg
forall a. IntMap a -> Int -> a
IM.!)(Int -> FX86Reg) -> (FAbsReg -> Int) -> FAbsReg -> FX86Reg
forall b c a. (b -> c) -> (a -> b) -> a -> c
.FAbsReg -> Int
fToInt)) [X86 AbsReg FAbsReg ()]
isns')
    where (IntMap X86Reg
regs, IntMap FX86Reg
fregs, [X86 AbsReg FAbsReg ()]
isns') = Int
-> [X86 AbsReg FAbsReg ()]
-> (IntMap X86Reg, IntMap FX86Reg, [X86 AbsReg FAbsReg ()])
gallocOn Int
u ([X86 AbsReg FAbsReg ()]
isns [X86 AbsReg FAbsReg ()]
-> [X86 AbsReg FAbsReg ()] -> [X86 AbsReg FAbsReg ()]
forall a. [a] -> [a] -> [a]
++ [() -> X86 AbsReg FAbsReg ()
forall reg freg a. a -> X86 reg freg a
Ret()])
          clob'd :: Set X86Reg
clob'd = [X86Reg] -> Set X86Reg
forall a. Ord a => [a] -> Set a
S.fromList ([X86Reg] -> Set X86Reg) -> [X86Reg] -> Set X86Reg
forall a b. (a -> b) -> a -> b
$ IntMap X86Reg -> [X86Reg]
forall a. IntMap a -> [a]
IM.elems IntMap X86Reg
regs

{-# SCC frame #-}
frame :: S.Set X86Reg -> [X86 X86Reg FX86Reg ()] -> [X86 X86Reg FX86Reg ()]
frame :: Set X86Reg -> [X86 X86Reg FX86Reg ()] -> [X86 X86Reg FX86Reg ()]
frame Set X86Reg
clob [X86 X86Reg FX86Reg ()]
asms = [X86 X86Reg FX86Reg ()]
forall {freg}. [X86 X86Reg freg ()]
pre[X86 X86Reg FX86Reg ()]
-> [X86 X86Reg FX86Reg ()] -> [X86 X86Reg FX86Reg ()]
forall a. [a] -> [a] -> [a]
++[X86 X86Reg FX86Reg ()]
asms[X86 X86Reg FX86Reg ()]
-> [X86 X86Reg FX86Reg ()] -> [X86 X86Reg FX86Reg ()]
forall a. [a] -> [a] -> [a]
++[X86 X86Reg FX86Reg ()]
forall {freg}. [X86 X86Reg freg ()]
post[X86 X86Reg FX86Reg ()]
-> [X86 X86Reg FX86Reg ()] -> [X86 X86Reg FX86Reg ()]
forall a. [a] -> [a] -> [a]
++[() -> X86 X86Reg FX86Reg ()
forall reg freg a. a -> X86 reg freg a
Ret()] where
    pre :: [X86 X86Reg freg ()]
pre = [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
forall {freg}. [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
save([X86 X86Reg freg ()] -> [X86 X86Reg freg ()])
-> [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
forall a b. (a -> b) -> a -> b
$() -> X86Reg -> X86 X86Reg freg ()
forall reg freg a. a -> reg -> X86 reg freg a
Push () (X86Reg -> X86 X86Reg freg ()) -> [X86Reg] -> [X86 X86Reg freg ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [X86Reg]
clobs
    post :: [X86 X86Reg freg ()]
post = [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
forall {freg}. [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
restore([X86 X86Reg freg ()] -> [X86 X86Reg freg ()])
-> [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
forall a b. (a -> b) -> a -> b
$() -> X86Reg -> X86 X86Reg freg ()
forall reg freg a. a -> reg -> X86 reg freg a
Pop () (X86Reg -> X86 X86Reg freg ()) -> [X86Reg] -> [X86 X86Reg freg ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [X86Reg] -> [X86Reg]
forall a. [a] -> [a]
reverse [X86Reg]
clobs
    clobs :: [X86Reg]
clobs = Set X86Reg -> [X86Reg]
forall a. Set a -> [a]
S.toList (Set X86Reg
clob Set X86Reg -> Set X86Reg -> Set X86Reg
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` [X86Reg] -> Set X86Reg
forall a. Ord a => [a] -> Set a
S.fromList (X86Reg
RbpX86Reg -> [X86Reg] -> [X86Reg]
forall a. a -> [a] -> [a]
:[X86Reg
R12 .. X86Reg
Rbx]))
    scratch :: Bool
scratch=Int -> Bool
forall a. Integral a => a -> Bool
even([X86Reg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [X86Reg]
clobs) Bool -> Bool -> Bool
&& [X86 X86Reg FX86Reg ()] -> Bool
forall reg freg a. [X86 reg freg a] -> Bool
hasMa [X86 X86Reg FX86Reg ()]
asms; save :: [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
save=if Bool
scratch then ([X86 X86Reg freg ()]
-> [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
forall a. [a] -> [a] -> [a]
++[() -> X86Reg -> Int64 -> X86 X86Reg freg ()
forall reg freg a. a -> reg -> Int64 -> X86 reg freg a
ISubRI () X86Reg
Rsp Int64
8]) else [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
forall a. a -> a
id; restore :: [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
restore=if Bool
scratch then (() -> X86Reg -> Int64 -> X86 X86Reg freg ()
forall reg freg a. a -> reg -> Int64 -> X86 reg freg a
IAddRI () X86Reg
Rsp Int64
8X86 X86Reg freg () -> [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
forall a. a -> [a] -> [a]
:) else [X86 X86Reg freg ()] -> [X86 X86Reg freg ()]
forall a. a -> a
id
    -- TODO: https://eli.thegreenplace.net/2011/09/06/stack-frame-layout-on-x86-64/
    -- https://stackoverflow.com/questions/51523127/why-does-the-compiler-reserve-a-little-stack-space-but-not-the-whole-array-size

{-# INLINE gallocOn #-}
gallocOn :: Int -> [X86 AbsReg FAbsReg ()] -> (IM.IntMap X86Reg, IM.IntMap FX86Reg, [X86 AbsReg FAbsReg ()])
gallocOn :: Int
-> [X86 AbsReg FAbsReg ()]
-> (IntMap X86Reg, IntMap FX86Reg, [X86 AbsReg FAbsReg ()])
gallocOn Int
u = Int
-> Int
-> IntMap X86Reg
-> Bool
-> [X86 AbsReg FAbsReg ()]
-> (IntMap X86Reg, IntMap FX86Reg, [X86 AbsReg FAbsReg ()])
go Int
u Int
16 IntMap X86Reg
pres Bool
True
    where go :: Int
-> Int
-> IntMap X86Reg
-> Bool
-> [X86 AbsReg FAbsReg ()]
-> (IntMap X86Reg, IntMap FX86Reg, [X86 AbsReg FAbsReg ()])
go Int
uϵ Int
offs IntMap X86Reg
pres' Bool
i [X86 AbsReg FAbsReg ()]
isns = (IntMap X86Reg, IntMap FX86Reg, [X86 AbsReg FAbsReg ()])
rmaps
              where rmaps :: (IntMap X86Reg, IntMap FX86Reg, [X86 AbsReg FAbsReg ()])
rmaps = case (Either IntSet (IntMap X86Reg)
regsM, Either IntSet (IntMap FX86Reg)
fregsM) of
                        (Right IntMap X86Reg
regs, Right IntMap FX86Reg
fregs) -> let saa :: Int64
saa = Int64 -> Int64
saI(Int64 -> Int64) -> Int64 -> Int64
forall a b. (a -> b) -> a -> b
$Int64
8Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
*Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offs; saaP :: [X86 AbsReg freg ()] -> [X86 AbsReg freg ()]
saaP = if Bool
i then [X86 AbsReg freg ()] -> [X86 AbsReg freg ()]
forall a. HasCallStack => [a] -> [a]
init else ([X86 AbsReg freg ()]
-> [X86 AbsReg freg ()] -> [X86 AbsReg freg ()]
forall a. [a] -> [a] -> [a]
++[() -> AbsReg -> Int64 -> X86 AbsReg freg ()
forall reg freg a. a -> reg -> Int64 -> X86 reg freg a
IAddRI () AbsReg
SP Int64
saa])([X86 AbsReg freg ()] -> [X86 AbsReg freg ()])
-> ([X86 AbsReg freg ()] -> [X86 AbsReg freg ()])
-> [X86 AbsReg freg ()]
-> [X86 AbsReg freg ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[X86 AbsReg freg ()] -> [X86 AbsReg freg ()]
forall a. HasCallStack => [a] -> [a]
init([X86 AbsReg freg ()] -> [X86 AbsReg freg ()])
-> ([X86 AbsReg freg ()] -> [X86 AbsReg freg ()])
-> [X86 AbsReg freg ()]
-> [X86 AbsReg freg ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(() -> AbsReg -> Int64 -> X86 AbsReg freg ()
forall reg freg a. a -> reg -> Int64 -> X86 reg freg a
ISubRI () AbsReg
SP Int64
saaX86 AbsReg freg () -> [X86 AbsReg freg ()] -> [X86 AbsReg freg ()]
forall a. a -> [a] -> [a]
:)([X86 AbsReg freg ()] -> [X86 AbsReg freg ()])
-> ([X86 AbsReg freg ()] -> [X86 AbsReg freg ()])
-> [X86 AbsReg freg ()]
-> [X86 AbsReg freg ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(() -> AbsReg -> Int64 -> X86 AbsReg freg ()
forall reg freg a. a -> reg -> Int64 -> X86 reg freg a
ISubRI () AbsReg
BP Int64
saaX86 AbsReg freg () -> [X86 AbsReg freg ()] -> [X86 AbsReg freg ()]
forall a. a -> [a] -> [a]
:) in (IntMap X86Reg
regs, IntMap FX86Reg
fregs, [X86 AbsReg FAbsReg ()] -> [X86 AbsReg FAbsReg ()]
forall {freg}. [X86 AbsReg freg ()] -> [X86 AbsReg freg ()]
saaP [X86 AbsReg FAbsReg ()]
isns)
                        (Left IntSet
s, Right IntMap FX86Reg
fregs) ->
                            let (Int
uϵ', Int
offs', [X86 AbsReg FAbsReg ()]
isns') = Int
-> Int
-> IntSet
-> [X86 AbsReg FAbsReg ()]
-> (Int, Int, [X86 AbsReg FAbsReg ()])
forall a.
Int
-> Int
-> IntSet
-> [X86 AbsReg FAbsReg a]
-> (Int, Int, [X86 AbsReg FAbsReg ()])
spill Int
uϵ Int
offs IntSet
s [X86 AbsReg FAbsReg ()]
isns
                            in Int
-> Int
-> IntMap X86Reg
-> Bool
-> [X86 AbsReg FAbsReg ()]
-> (IntMap X86Reg, IntMap FX86Reg, [X86 AbsReg FAbsReg ()])
go Int
uϵ' Int
offs' (Int -> X86Reg -> IntMap X86Reg -> IntMap X86Reg
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (-Int
16) X86Reg
Rbp IntMap X86Reg
pres') Bool
False [X86 AbsReg FAbsReg ()]
isns'
                    regsM :: Either IntSet (IntMap X86Reg)
regsM = [X86 AbsReg FAbsReg (UD, Liveness, Maybe (Int, Int))]
-> [X86Reg]
-> IntSet
-> IntMap X86Reg
-> Either IntSet (IntMap X86Reg)
forall reg (arch :: * -> * -> * -> *) areg afreg.
(Ord reg, Arch arch areg afreg, Copointed (arch areg afreg)) =>
[arch areg afreg (UD, Liveness, Maybe (Int, Int))]
-> [reg] -> IntSet -> IntMap reg -> Either IntSet (IntMap reg)
alloc [X86 AbsReg FAbsReg (UD, Liveness, Maybe (Int, Int))]
aIsns ((if Bool
i then ([X86Reg] -> [X86Reg] -> [X86Reg]
forall a. [a] -> [a] -> [a]
++[X86Reg
Rbp]) else [X86Reg] -> [X86Reg]
forall a. a -> a
id) [X86Reg
Rcx .. X86Reg
Rax]) (IntMap X86Reg -> IntSet
forall a. IntMap a -> IntSet
IM.keysSet IntMap X86Reg
pres') IntMap X86Reg
pres'
                    fregsM :: Either IntSet (IntMap FX86Reg)
fregsM = [X86 AbsReg FAbsReg (UD, Liveness, Maybe (Int, Int))]
-> [FX86Reg]
-> IntSet
-> IntMap FX86Reg
-> Either IntSet (IntMap FX86Reg)
forall reg (arch :: * -> * -> * -> *) areg afreg.
(Ord reg, Arch arch areg afreg, Copointed (arch areg afreg)) =>
[arch areg afreg (UD, Liveness, Maybe (Int, Int))]
-> [reg] -> IntSet -> IntMap reg -> Either IntSet (IntMap reg)
allocF [X86 AbsReg FAbsReg (UD, Liveness, Maybe (Int, Int))]
aFIsns [FX86Reg
XMM1 .. FX86Reg
XMM15] (IntMap FX86Reg -> IntSet
forall a. IntMap a -> IntSet
IM.keysSet IntMap FX86Reg
preFs) IntMap FX86Reg
preFs
                    ([X86 AbsReg FAbsReg (UD, Liveness, Maybe (Int, Int))]
aIsns, [X86 AbsReg FAbsReg (UD, Liveness, Maybe (Int, Int))]
aFIsns) = [X86 AbsReg FAbsReg ()]
-> ([X86 AbsReg FAbsReg (UD, Liveness, Maybe (Int, Int))],
    [X86 AbsReg FAbsReg (UD, Liveness, Maybe (Int, Int))])
forall reg freg (arch :: * -> * -> * -> *).
(E reg, E freg, Copointed (arch reg freg), Arch arch reg freg) =>
[arch reg freg ()]
-> ([arch reg freg (UD, Liveness, Maybe (Int, Int))],
    [arch reg freg (UD, Liveness, Maybe (Int, Int))])
bundle [X86 AbsReg FAbsReg ()]
isns

saI :: Int64 -> Int64
saI :: Int64 -> Int64
saI Int64
i | Int64
iInt64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`rem`Int64
16 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0 = Int64
i | Bool
otherwise = Int64
iInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
8

pres :: IM.IntMap X86Reg
pres :: IntMap X86Reg
pres = [(Int, X86Reg)] -> IntMap X86Reg
forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
0, X86Reg
Rdi), (Int
1, X86Reg
Rsi), (Int
2, X86Reg
Rdx), (Int
3, X86Reg
Rcx), (Int
4, X86Reg
R8), (Int
5, X86Reg
R9), (Int
6, X86Reg
Rax), (Int
7, X86Reg
Rsp)]

preFs :: IM.IntMap FX86Reg
preFs :: IntMap FX86Reg
preFs = [(Int, FX86Reg)] -> IntMap FX86Reg
forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
8, FX86Reg
XMM0), (Int
9, FX86Reg
XMM1), (Int
10, FX86Reg
XMM2), (Int
11, FX86Reg
XMM3), (Int
12, FX86Reg
XMM4), (Int
13, FX86Reg
XMM5), (Int
14, FX86Reg
XMM6), (Int
15, FX86Reg
XMM7)]