module GHC.Cmm.CallConv (
  ParamLocation(..),
  assignArgumentsPos,
  assignStack,
  realArgRegsCover,
  allArgRegsCover
) where

import GHC.Prelude

import GHC.Cmm.Expr
import GHC.Cmm.Reg (GlobalArgRegs(..))
import GHC.Runtime.Heap.Layout
import GHC.Cmm (Convention(..))

import GHC.Platform
import GHC.Platform.Reg.Class
import GHC.Platform.Profile
import GHC.Utils.Outputable
import GHC.Utils.Panic

import Data.Maybe ( maybeToList )
import Data.List (nub)

-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.

data ParamLocation
  = RegisterParam GlobalReg
  | StackParam ByteOff

instance Outputable ParamLocation where
  ppr :: ParamLocation -> SDoc
ppr (RegisterParam GlobalReg
g) = GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
g
  ppr (StackParam Int
p)    = Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
p

-- |
-- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed
--
assignArgumentsPos :: Profile
                   -> ByteOff           -- stack offset to start with
                   -> Convention
                   -> (a -> CmmType)    -- how to get a type from an arg
                   -> [a]               -- args
                   -> (
                        ByteOff              -- bytes of stack args
                      , [(a, ParamLocation)] -- args and locations
                      )

assignArgumentsPos :: forall a.
Profile
-> Int
-> Convention
-> (a -> CmmType)
-> [a]
-> (Int, [(a, ParamLocation)])
assignArgumentsPos Profile
profile Int
off Convention
conv a -> CmmType
arg_ty [a]
reps = (Int
stk_off, [(a, ParamLocation)]
assignments)
    where
      platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
      regs :: AvailRegs
regs = case ([a]
reps, Convention
conv) of
               ([a]
_,   Convention
NativeNodeCall)   -> Platform -> AvailRegs
getRegsWithNode Platform
platform
               ([a]
_,   Convention
NativeDirectCall) -> Platform -> AvailRegs
getRegsWithoutNode Platform
platform
               ([a
_], Convention
NativeReturn)     -> Platform -> AvailRegs
allRegs Platform
platform
               ([a]
_,   Convention
NativeReturn)     -> Platform -> AvailRegs
getRegsWithNode Platform
platform
               -- GC calling convention *must* put values in registers
               ([a]
_,   Convention
GC)               -> Platform -> AvailRegs
allRegs Platform
platform
               ([a]
_,   Convention
Slow)             -> AvailRegs
nodeOnly
      -- The calling conventions first assign arguments to registers,
      -- then switch to the stack when we first run out of registers
      -- (even if there are still available registers for args of a
      -- different type).  When returning an unboxed tuple, we also
      -- separate the stack arguments by pointerhood.
      ([(a, ParamLocation)]
reg_assts, [a]
stk_args)  = [(a, ParamLocation)]
-> [a] -> AvailRegs -> ([(a, ParamLocation)], [a])
assign_regs [] [a]
reps AvailRegs
regs
      (Int
stk_off,   [(a, ParamLocation)]
stk_assts) = Platform
-> Int -> (a -> CmmType) -> [a] -> (Int, [(a, ParamLocation)])
forall a.
Platform
-> Int -> (a -> CmmType) -> [a] -> (Int, [(a, ParamLocation)])
assignStack Platform
platform Int
off a -> CmmType
arg_ty [a]
stk_args
      assignments :: [(a, ParamLocation)]
assignments = [(a, ParamLocation)]
reg_assts [(a, ParamLocation)]
-> [(a, ParamLocation)] -> [(a, ParamLocation)]
forall a. [a] -> [a] -> [a]
++ [(a, ParamLocation)]
stk_assts

      assign_regs :: [(a, ParamLocation)]
-> [a] -> AvailRegs -> ([(a, ParamLocation)], [a])
assign_regs [(a, ParamLocation)]
assts []     AvailRegs
_    = ([(a, ParamLocation)]
assts, [])
      assign_regs [(a, ParamLocation)]
assts (a
r:[a]
rs) AvailRegs
regs | CmmType -> Bool
isVecType CmmType
ty   = ([(a, ParamLocation)], [a])
vec
                                    | CmmType -> Bool
isFloatType CmmType
ty = ([(a, ParamLocation)], [a])
float
                                    | Bool
otherwise      = ([(a, ParamLocation)], [a])
int
        where vec :: ([(a, ParamLocation)], [a])
vec = case AvailRegs
regs of
                      AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls (Int
s:[Int]
ss)
                        | Width -> Profile -> Bool
passVectorInReg Width
w Profile
profile
                          -> let reg_class :: Int -> GlobalReg
reg_class = case Width
w of
                                    Width
W128 -> Int -> GlobalReg
XmmReg
                                    Width
W256 -> Int -> GlobalReg
YmmReg
                                    Width
W512 -> Int -> GlobalReg
ZmmReg
                                    Width
_    -> String -> Int -> GlobalReg
forall a. HasCallStack => String -> a
panic String
"CmmCallConv.assignArgumentsPos: Invalid vector width"
                              in (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam (Int -> GlobalReg
reg_class Int
s), [GlobalReg]
-> [GlobalReg] -> [GlobalReg] -> [GlobalReg] -> [Int] -> AvailRegs
AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls [Int]
ss)
                      AvailRegs
_ -> ([(a, ParamLocation)]
assts, a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs)
              float :: ([(a, ParamLocation)], [a])
float = case (Width
w, AvailRegs
regs) of
                        (Width
W32, AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls (Int
s:[Int]
ss))
                            | Bool
passFloatInXmm          -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam (Int -> GlobalReg
FloatReg Int
s), [GlobalReg]
-> [GlobalReg] -> [GlobalReg] -> [GlobalReg] -> [Int] -> AvailRegs
AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls [Int]
ss)
                        (Width
W32, AvailRegs [GlobalReg]
vs (GlobalReg
f:[GlobalReg]
fs) [GlobalReg]
ds [GlobalReg]
ls [Int]
ss)
                            | Bool -> Bool
not Bool
passFloatInXmm      -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam GlobalReg
f, [GlobalReg]
-> [GlobalReg] -> [GlobalReg] -> [GlobalReg] -> [Int] -> AvailRegs
AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls [Int]
ss)
                        (Width
W64, AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls (Int
s:[Int]
ss))
                            | Bool
passFloatInXmm          -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam (Int -> GlobalReg
DoubleReg Int
s), [GlobalReg]
-> [GlobalReg] -> [GlobalReg] -> [GlobalReg] -> [Int] -> AvailRegs
AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls [Int]
ss)
                        (Width
W64, AvailRegs [GlobalReg]
vs [GlobalReg]
fs (GlobalReg
d:[GlobalReg]
ds) [GlobalReg]
ls [Int]
ss)
                            | Bool -> Bool
not Bool
passFloatInXmm      -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam GlobalReg
d, [GlobalReg]
-> [GlobalReg] -> [GlobalReg] -> [GlobalReg] -> [Int] -> AvailRegs
AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls [Int]
ss)
                        (Width, AvailRegs)
_ -> ([(a, ParamLocation)]
assts, (a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs))
              int :: ([(a, ParamLocation)], [a])
int = case (Width
w, AvailRegs
regs) of
                      (Width
W128, AvailRegs
_) -> String -> ([(a, ParamLocation)], [a])
forall a. HasCallStack => String -> a
panic String
"W128 unsupported register type"
                      (Width
_, AvailRegs (GlobalReg
v:[GlobalReg]
vs) [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls [Int]
ss) | Width -> Int
widthInBits Width
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Width -> Int
widthInBits (Platform -> Width
wordWidth Platform
platform)
                          -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam GlobalReg
v, [GlobalReg]
-> [GlobalReg] -> [GlobalReg] -> [GlobalReg] -> [Int] -> AvailRegs
AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls [Int]
ss)
                      (Width
_, AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds (GlobalReg
l:[GlobalReg]
ls) [Int]
ss) | Width -> Int
widthInBits Width
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Width -> Int
widthInBits (Platform -> Width
wordWidth Platform
platform)
                          -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam GlobalReg
l, [GlobalReg]
-> [GlobalReg] -> [GlobalReg] -> [GlobalReg] -> [Int] -> AvailRegs
AvailRegs [GlobalReg]
vs [GlobalReg]
fs [GlobalReg]
ds [GlobalReg]
ls [Int]
ss)
                      (Width, AvailRegs)
_   -> ([(a, ParamLocation)]
assts, (a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs))
              k :: (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (ParamLocation
asst, AvailRegs
regs') = [(a, ParamLocation)]
-> [a] -> AvailRegs -> ([(a, ParamLocation)], [a])
assign_regs ((a
r, ParamLocation
asst) (a, ParamLocation) -> [(a, ParamLocation)] -> [(a, ParamLocation)]
forall a. a -> [a] -> [a]
: [(a, ParamLocation)]
assts) [a]
rs AvailRegs
regs'
              ty :: CmmType
ty = a -> CmmType
arg_ty a
r
              w :: Width
w  = CmmType -> Width
typeWidth CmmType
ty
              passFloatInXmm :: Bool
passFloatInXmm = Platform -> Bool
passFloatArgsInXmm Platform
platform

passFloatArgsInXmm :: Platform -> Bool
passFloatArgsInXmm :: Platform -> Bool
passFloatArgsInXmm Platform
platform =
  -- TODO: replace the following logic by casing on @registerArch (platformArch platform)@.
  --
  -- This will mean we start saying "True" for AArch64, which the rest of the AArch64
  -- compilation pipeline will need to be able to handle (e.g. the AArch64 NCG).
  case Platform -> Arch
platformArch Platform
platform of
    Arch
ArchX86_64 -> Bool
True
    Arch
ArchX86    -> Bool
False
    Arch
_          -> Bool
False

-- We used to spill vector registers to the stack since the LLVM backend didn't
-- support vector registers in its calling convention. However, this has now
-- been fixed. This function remains only as a convenient way to re-enable
-- spilling when debugging code generation.
passVectorInReg :: Width -> Profile -> Bool
passVectorInReg :: Width -> Profile -> Bool
passVectorInReg Width
_ Profile
_ = Bool
True

assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]
            -> (
                 ByteOff              -- bytes of stack args
               , [(a, ParamLocation)] -- args and locations
               )
assignStack :: forall a.
Platform
-> Int -> (a -> CmmType) -> [a] -> (Int, [(a, ParamLocation)])
assignStack Platform
platform Int
offset a -> CmmType
arg_ty [a]
args = Int -> [(a, ParamLocation)] -> [a] -> (Int, [(a, ParamLocation)])
assign_stk Int
offset [] ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
args)
 where
      assign_stk :: Int -> [(a, ParamLocation)] -> [a] -> (Int, [(a, ParamLocation)])
assign_stk Int
offset [(a, ParamLocation)]
assts [] = (Int
offset, [(a, ParamLocation)]
assts)
      assign_stk Int
offset [(a, ParamLocation)]
assts (a
r:[a]
rs)
        = Int -> [(a, ParamLocation)] -> [a] -> (Int, [(a, ParamLocation)])
assign_stk Int
off' ((a
r, Int -> ParamLocation
StackParam Int
off') (a, ParamLocation) -> [(a, ParamLocation)] -> [(a, ParamLocation)]
forall a. a -> [a] -> [a]
: [(a, ParamLocation)]
assts) [a]
rs
        where w :: Width
w    = CmmType -> Width
typeWidth (a -> CmmType
arg_ty a
r)
              off' :: Int
off' = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size
              -- Stack arguments always take a whole number of words, we never
              -- pack them unlike constructor fields.
              size :: Int
size = Platform -> Int -> Int
roundUpToWords Platform
platform (Width -> Int
widthInBytes Width
w)

-----------------------------------------------------------------------------
-- Local information about the registers available

-- | Keep track of locally available registers.
data AvailRegs
  = AvailRegs
    { AvailRegs -> [GlobalReg]
availVanillaRegs :: [GlobalReg]
       -- ^ Available vanilla registers
    , AvailRegs -> [GlobalReg]
availFloatRegs   :: [GlobalReg]
       -- ^ Available float registers
    , AvailRegs -> [GlobalReg]
availDoubleRegs  :: [GlobalReg]
       -- ^ Available double registers
    , AvailRegs -> [GlobalReg]
availLongRegs    :: [GlobalReg]
       -- ^ Available long registers
    , AvailRegs -> [Int]
availXMMRegs     :: [Int]
       -- ^ Available vector XMM registers
    }

noAvailRegs :: AvailRegs
noAvailRegs :: AvailRegs
noAvailRegs = [GlobalReg]
-> [GlobalReg] -> [GlobalReg] -> [GlobalReg] -> [Int] -> AvailRegs
AvailRegs [] [] [] [] []

-- Vanilla registers can contain pointers, Ints, Chars.
-- Floats and doubles have separate register supplies.
--
-- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers.

getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs
getRegsWithoutNode :: Platform -> AvailRegs
getRegsWithoutNode Platform
platform =
  AvailRegs
   { availVanillaRegs :: [GlobalReg]
availVanillaRegs = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\GlobalReg
r -> GlobalReg
r GlobalReg -> GlobalReg -> Bool
forall a. Eq a => a -> a -> Bool
/= GlobalReg
node) (Platform -> [GlobalReg]
realVanillaRegs Platform
platform)
   , availFloatRegs :: [GlobalReg]
availFloatRegs   = Platform -> [GlobalReg]
realFloatRegs Platform
platform
   , availDoubleRegs :: [GlobalReg]
availDoubleRegs  = Platform -> [GlobalReg]
realDoubleRegs Platform
platform
   , availLongRegs :: [GlobalReg]
availLongRegs    = Platform -> [GlobalReg]
realLongRegs Platform
platform
   , availXMMRegs :: [Int]
availXMMRegs     = Platform -> [Int]
realXmmRegNos Platform
platform }

-- getRegsWithNode uses R1/node even if it isn't a register
getRegsWithNode :: Platform -> AvailRegs
getRegsWithNode Platform
platform =
  AvailRegs
   { availVanillaRegs :: [GlobalReg]
availVanillaRegs = if [GlobalReg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Platform -> [GlobalReg]
realVanillaRegs Platform
platform)
                        then [Int -> GlobalReg
VanillaReg Int
1]
                        else Platform -> [GlobalReg]
realVanillaRegs Platform
platform
   , availFloatRegs :: [GlobalReg]
availFloatRegs   = Platform -> [GlobalReg]
realFloatRegs Platform
platform
   , availDoubleRegs :: [GlobalReg]
availDoubleRegs  = Platform -> [GlobalReg]
realDoubleRegs Platform
platform
   , availLongRegs :: [GlobalReg]
availLongRegs    = Platform -> [GlobalReg]
realLongRegs Platform
platform
   , availXMMRegs :: [Int]
availXMMRegs     = Platform -> [Int]
realXmmRegNos Platform
platform }

allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg]
allVanillaRegs :: Platform -> [GlobalReg]
allXmmRegs :: Platform -> [Int]

allVanillaRegs :: Platform -> [GlobalReg]
allVanillaRegs Platform
platform = (Int -> GlobalReg) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
VanillaReg ([Int] -> [GlobalReg]) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_Vanilla_REG (Platform -> PlatformConstants
platformConstants Platform
platform))
allFloatRegs :: Platform -> [GlobalReg]
allFloatRegs   Platform
platform = (Int -> GlobalReg) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
FloatReg   ([Int] -> [GlobalReg]) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_Float_REG   (Platform -> PlatformConstants
platformConstants Platform
platform))
allDoubleRegs :: Platform -> [GlobalReg]
allDoubleRegs  Platform
platform = (Int -> GlobalReg) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
DoubleReg  ([Int] -> [GlobalReg]) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_Double_REG  (Platform -> PlatformConstants
platformConstants Platform
platform))
allLongRegs :: Platform -> [GlobalReg]
allLongRegs    Platform
platform = (Int -> GlobalReg) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
LongReg    ([Int] -> [GlobalReg]) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_Long_REG    (Platform -> PlatformConstants
platformConstants Platform
platform))
allXmmRegs :: Platform -> [Int]
allXmmRegs     Platform
platform =                  Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_XMM_REG     (Platform -> PlatformConstants
platformConstants Platform
platform))

realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg]
realVanillaRegs :: Platform -> [GlobalReg]

realVanillaRegs :: Platform -> [GlobalReg]
realVanillaRegs Platform
platform = (Int -> GlobalReg) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
VanillaReg ([Int] -> [GlobalReg]) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_Real_Vanilla_REG (Platform -> PlatformConstants
platformConstants Platform
platform))
realFloatRegs :: Platform -> [GlobalReg]
realFloatRegs   Platform
platform = (Int -> GlobalReg) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
FloatReg   ([Int] -> [GlobalReg]) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_Real_Float_REG   (Platform -> PlatformConstants
platformConstants Platform
platform))
realDoubleRegs :: Platform -> [GlobalReg]
realDoubleRegs  Platform
platform = (Int -> GlobalReg) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
DoubleReg  ([Int] -> [GlobalReg]) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_Real_Double_REG  (Platform -> PlatformConstants
platformConstants Platform
platform))
realLongRegs :: Platform -> [GlobalReg]
realLongRegs    Platform
platform = (Int -> GlobalReg) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
LongReg    ([Int] -> [GlobalReg]) -> [Int] -> [GlobalReg]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_Real_Long_REG    (Platform -> PlatformConstants
platformConstants Platform
platform))

realXmmRegNos :: Platform -> [Int]
realXmmRegNos :: Platform -> [Int]
realXmmRegNos Platform
platform
    | Platform -> Bool
isSse2Enabled Platform
platform Bool -> Bool -> Bool
|| Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchAArch64
    = Int -> [Int]
regList (PlatformConstants -> Int
pc_MAX_Real_XMM_REG (Platform -> PlatformConstants
platformConstants Platform
platform))
    | Bool
otherwise
    = []

regList :: Int -> [Int]
regList :: Int -> [Int]
regList Int
n = [Int
1 .. Int
n]

allRegs :: Platform -> AvailRegs
allRegs :: Platform -> AvailRegs
allRegs Platform
platform =
  AvailRegs
   { availVanillaRegs :: [GlobalReg]
availVanillaRegs = Platform -> [GlobalReg]
allVanillaRegs Platform
platform
   , availFloatRegs :: [GlobalReg]
availFloatRegs   = Platform -> [GlobalReg]
allFloatRegs   Platform
platform
   , availDoubleRegs :: [GlobalReg]
availDoubleRegs  = Platform -> [GlobalReg]
allDoubleRegs  Platform
platform
   , availLongRegs :: [GlobalReg]
availLongRegs    = Platform -> [GlobalReg]
allLongRegs    Platform
platform
   , availXMMRegs :: [Int]
availXMMRegs     = Platform -> [Int]
allXmmRegs     Platform
platform }

nodeOnly :: AvailRegs
nodeOnly :: AvailRegs
nodeOnly = AvailRegs
noAvailRegs { availVanillaRegs = [VanillaReg 1] }

-- | A set of global registers that cover the machine registers used
-- for argument passing.
--
-- See Note [realArgRegsCover].
realArgRegsCover :: Platform
                 -> GlobalArgRegs
                    -- ^ which kinds of registers do we want to cover?
                 -> [GlobalReg]
realArgRegsCover :: Platform -> GlobalArgRegs -> [GlobalReg]
realArgRegsCover Platform
platform GlobalArgRegs
argRegs
  =  Platform -> [GlobalReg]
realVanillaRegs Platform
platform
  [GlobalReg] -> [GlobalReg] -> [GlobalReg]
forall a. [a] -> [a] -> [a]
++ Platform -> [GlobalReg]
realLongRegs    Platform
platform
  [GlobalReg] -> [GlobalReg] -> [GlobalReg]
forall a. [a] -> [a] -> [a]
++ [[GlobalReg]] -> [GlobalReg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      (  [ Platform -> [GlobalReg]
realFloatRegs Platform
platform  | Bool
wantFP, Bool -> Bool
not (Platform -> Bool
passFloatArgsInXmm Platform
platform) ]
           -- TODO: the line above is legacy logic, but removing it breaks
           -- the bytecode interpreter on AArch64. Probably easy to fix.
           -- AK: I believe this might be because we map REG_F1..4 and REG_D1..4 to different
           -- machine registers on AArch64.
      [[GlobalReg]] -> [[GlobalReg]] -> [[GlobalReg]]
forall a. [a] -> [a] -> [a]
++ [ Platform -> [GlobalReg]
realDoubleRegs Platform
platform | Bool
wantFP ]
      )
  [GlobalReg] -> [GlobalReg] -> [GlobalReg]
forall a. [a] -> [a] -> [a]
++ [ Int -> GlobalReg
mkVecReg Int
i | Int -> GlobalReg
mkVecReg <- Maybe (Int -> GlobalReg) -> [Int -> GlobalReg]
forall a. Maybe a -> [a]
maybeToList Maybe (Int -> GlobalReg)
mbMkVecReg
                  , Int
i <- Platform -> [Int]
realXmmRegNos Platform
platform ]

  where
    wantFP :: Bool
wantFP = case Arch -> RegArch
registerArch (Platform -> Arch
platformArch Platform
platform) of
      RegArch
Unified   -> GlobalArgRegs
argRegs GlobalArgRegs -> GlobalArgRegs -> Bool
forall a. Eq a => a -> a -> Bool
== GlobalArgRegs
SCALAR_ARG_REGS
      RegArch
Separate  -> GlobalArgRegs
argRegs GlobalArgRegs -> GlobalArgRegs -> Bool
forall a. Ord a => a -> a -> Bool
>= GlobalArgRegs
SCALAR_ARG_REGS
      RegArch
NoVectors -> GlobalArgRegs
argRegs GlobalArgRegs -> GlobalArgRegs -> Bool
forall a. Ord a => a -> a -> Bool
>= GlobalArgRegs
SCALAR_ARG_REGS
    mbMkVecReg :: Maybe (Int -> GlobalReg)
mbMkVecReg = case Arch -> RegArch
registerArch (Platform -> Arch
platformArch Platform
platform) of
      RegArch
Unified   -> Maybe (Int -> GlobalReg)
mb_xyzmm
      RegArch
Separate  -> Maybe (Int -> GlobalReg)
mb_xyzmm
      RegArch
NoVectors -> Maybe (Int -> GlobalReg)
forall a. Maybe a
Nothing
    mb_xyzmm :: Maybe (Int -> GlobalReg)
mb_xyzmm = case GlobalArgRegs
argRegs of
      GlobalArgRegs
V16_ARG_REGS -> (Int -> GlobalReg) -> Maybe (Int -> GlobalReg)
forall a. a -> Maybe a
Just Int -> GlobalReg
XmmReg
      GlobalArgRegs
V32_ARG_REGS -> (Int -> GlobalReg) -> Maybe (Int -> GlobalReg)
forall a. a -> Maybe a
Just Int -> GlobalReg
YmmReg
      GlobalArgRegs
V64_ARG_REGS -> (Int -> GlobalReg) -> Maybe (Int -> GlobalReg)
forall a. a -> Maybe a
Just Int -> GlobalReg
ZmmReg
      GlobalArgRegs
_ -> Maybe (Int -> GlobalReg)
forall a. Maybe a
Nothing

-- | Like "realArgRegsCover", but always includes the node.
--
-- See Note [realArgRegsCover].
allArgRegsCover :: Platform
                -> GlobalArgRegs
                    -- ^ which kinds of registers do we want to cover?
                -> [GlobalReg]
allArgRegsCover :: Platform -> GlobalArgRegs -> [GlobalReg]
allArgRegsCover Platform
platform GlobalArgRegs
argRegs =
  [GlobalReg] -> [GlobalReg]
forall a. Eq a => [a] -> [a]
nub (GlobalReg
node GlobalReg -> [GlobalReg] -> [GlobalReg]
forall a. a -> [a] -> [a]
: Platform -> GlobalArgRegs -> [GlobalReg]
realArgRegsCover Platform
platform GlobalArgRegs
argRegs)
  where
    node :: GlobalReg
node = Int -> GlobalReg
VanillaReg Int
1

{- Note [realArgRegsCover]
~~~~~~~~~~~~~~~~~~~~~~~~~~
In low-level Cmm, jumps must be annotated with a set of live registers,
allowing precise control of global STG register contents across function calls.
However, in some places (in particular in the RTS), the registers we want to
preserve depend on the *caller*. For example, if we intercept a function call
via a stack underflow frame, we want to preserve exactly those registers
containing function arguments.
Since we can't know exactly how many arguments the caller passed, we settle on
simply preserving all global regs which might be used for argument passing.
To do this, we specify a collection of registers that *covers* all the registers
we want to preserve; this is done by "realArgRegsCover".

The situation is made somewhat tricky by the need to handle vector registers.
For example, on X86_64, the F, D, XMM, YMM, ZMM overlap in the following way
          ┌─┬─┬───┬───────┬───────────────┐
          │F┆D┆XMM┆  YMM  ┆     ZMM       │
          └─┴─┴───┴───────┴───────────────┘
where each register extends all the way to the left.

Based on this register architecture, on X86_64 we might want to annotate a jump
in which we (might) want to preserve the contents of all argument-passing
registers with [R1, ..., R6, ZMM1, ..., ZMM6]. This, however, is not possible
in general, because preserving e.g. a ZMM register across a C call requires the
availability of the AVX-512F instruction set. If we did this, the RTS would
crash at runtime with an "invalid instruction" error on X86_64 machines which
do not support AVX-512F.

Instead, we parametrise "realArgRegsCover" on the 'GlobalArgRegs' datatype, which
specifies which registers it is sufficient to preserve. For example, it might
suffice to only preserve general-purpose registers, or to only preserve up to
XMM (not YMM or ZMM).

Then, to handle certain functions in the RTS such as "stack_underflow_frame", we
proceed by defining 4 variants, stack_underflow_frame_{d,v16,v32,v64}, which
respectively annotate the jump at the end of the function with SCALAR_ARG_REGS,
V16_ARG_REGS, V32_ARG_REGS and V64_ARG_REGS. Compiling these variants, in effect,
amounts to compiling "stack_underflow_frame" four times, once for each level of
vector support. Then, in the RTS, we dispatch at runtime based on the support
for vectors provided by the architecture on the current machine (see e.g.
'threadStackOverflow' and its 'switch (vectorSupportGlobalVar)'.)

Note that, like in Note [AutoApply.cmm for vectors], it is **critical** that we
compile e.g. stack_underflow_frame_v64 with -mavx512f. If we don't, the LLVM
backend is liable to compile code using e.g. the ZMM1 STG register to uses of
X86 machine registers xmm1, xmm2, xmm3, xmm4, instead of just zmm1. This would
mean that LLVM produces ABI-incompatible code that would result in segfaults in
the RTS.
-}