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

import GHC.Prelude
import Data.List (nub)

import GHC.Cmm.Expr
import GHC.Runtime.Heap.Layout
import GHC.Cmm (Convention(..))
import GHC.Cmm.Ppr () -- For Outputable instances

import GHC.Driver.Session
import GHC.Platform
import GHC.Platform.Profile
import GHC.Utils.Outputable
import GHC.Utils.Panic

-- 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) = forall a. Outputable a => a -> SDoc
ppr GlobalReg
g
  ppr (StackParam Int
p)    = 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) = 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 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 (Width
w, AvailRegs
regs) of
                      (Width
W128, ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, Int
s:[Int]
ss))
                          | Width -> Profile -> Bool
passVectorInReg Width
W128 Profile
profile -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam (Int -> GlobalReg
XmmReg Int
s), ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss))
                      (Width
W256, ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, Int
s:[Int]
ss))
                          | Width -> Profile -> Bool
passVectorInReg Width
W256 Profile
profile -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam (Int -> GlobalReg
YmmReg Int
s), ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss))
                      (Width
W512, ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, Int
s:[Int]
ss))
                          | Width -> Profile -> Bool
passVectorInReg Width
W512 Profile
profile -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam (Int -> GlobalReg
ZmmReg Int
s), ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss))
                      (Width, AvailRegs)
_ -> ([(a, ParamLocation)]
assts, (a
rforall a. a -> [a] -> [a]
:[a]
rs))
              float :: ([(a, ParamLocation)], [a])
float = case (Width
w, AvailRegs
regs) of
                        (Width
W32, ([VGcPtr -> 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), ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss))
                        (Width
W32, ([VGcPtr -> 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, ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss))
                        (Width
W64, ([VGcPtr -> 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), ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss))
                        (Width
W64, ([VGcPtr -> 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, ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss))
                        (Width, AvailRegs)
_ -> ([(a, ParamLocation)]
assts, (a
rforall a. a -> [a] -> [a]
:[a]
rs))
              int :: ([(a, ParamLocation)], [a])
int = case (Width
w, AvailRegs
regs) of
                      (Width
W128, AvailRegs
_) -> forall a. String -> a
panic String
"W128 unsupported register type"
                      (Width
_, (VGcPtr -> GlobalReg
v:[VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss)) | Width -> Int
widthInBits Width
w forall a. Ord a => a -> a -> Bool
<= Width -> Int
widthInBits (Platform -> Width
wordWidth Platform
platform)
                          -> (ParamLocation, AvailRegs) -> ([(a, ParamLocation)], [a])
k (GlobalReg -> ParamLocation
RegisterParam (VGcPtr -> GlobalReg
v VGcPtr
gcp), ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss))
                      (Width
_, ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, GlobalReg
l:[GlobalReg]
ls, [Int]
ss)) | Width -> Int
widthInBits Width
w 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, ([VGcPtr -> GlobalReg]
vs, [GlobalReg]
fs, [GlobalReg]
ds, [GlobalReg]
ls, [Int]
ss))
                      (Width, AvailRegs)
_   -> ([(a, ParamLocation)]
assts, (a
rforall 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) 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
              !gcp :: VGcPtr
gcp | CmmType -> Bool
isGcPtrType CmmType
ty = VGcPtr
VGcPtr
                   | Bool
otherwise      = VGcPtr
VNonGcPtr
              passFloatInXmm :: Bool
passFloatInXmm = Platform -> Bool
passFloatArgsInXmm Platform
platform

passFloatArgsInXmm :: Platform -> Bool
passFloatArgsInXmm :: Platform -> Bool
passFloatArgsInXmm Platform
platform = 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 [] (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') 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 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

type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
                 , [GlobalReg]   -- floats
                 , [GlobalReg]   -- doubles
                 , [GlobalReg]   -- longs (int64 and word64)
                 , [Int]         -- XMM (floats and doubles)
                 )

-- 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 =
  ( forall a. (a -> Bool) -> [a] -> [a]
filter (\VGcPtr -> GlobalReg
r -> VGcPtr -> GlobalReg
r VGcPtr
VGcPtr forall a. Eq a => a -> a -> Bool
/= GlobalReg
node) (Platform -> [VGcPtr -> GlobalReg]
realVanillaRegs Platform
platform)
  , Platform -> [GlobalReg]
realFloatRegs Platform
platform
  , Platform -> [GlobalReg]
realDoubleRegs Platform
platform
  , Platform -> [GlobalReg]
realLongRegs Platform
platform
  , Platform -> [Int]
realXmmRegNos Platform
platform)

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

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

allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
allVanillaRegs Platform
platform = forall a b. (a -> b) -> [a] -> [b]
map Int -> VGcPtr -> GlobalReg
VanillaReg 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 = forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
FloatReg   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 = forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
DoubleReg  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 = forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
LongReg    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 -> [VGcPtr -> GlobalReg]

realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
realVanillaRegs Platform
platform = forall a b. (a -> b) -> [a] -> [b]
map Int -> VGcPtr -> GlobalReg
VanillaReg 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 = forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
FloatReg   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 = forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
DoubleReg  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 = forall a b. (a -> b) -> [a] -> [b]
map Int -> GlobalReg
LongReg    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 = 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 = ( Platform -> [VGcPtr -> GlobalReg]
allVanillaRegs Platform
platform
                   , Platform -> [GlobalReg]
allFloatRegs   Platform
platform
                   , Platform -> [GlobalReg]
allDoubleRegs  Platform
platform
                   , Platform -> [GlobalReg]
allLongRegs    Platform
platform
                   , Platform -> [Int]
allXmmRegs     Platform
platform
                   )

nodeOnly :: AvailRegs
nodeOnly :: AvailRegs
nodeOnly = ([Int -> VGcPtr -> GlobalReg
VanillaReg Int
1], [], [], [], [])

-- This returns the set of global registers that *cover* the machine registers
-- used for argument passing. On platforms where registers can overlap---right
-- now just x86-64, where Float and Double registers overlap---passing this set
-- of registers is guaranteed to preserve the contents of all live registers. We
-- only use this functionality in hand-written C-- code in the RTS.
realArgRegsCover :: Platform -> [GlobalReg]
realArgRegsCover :: Platform -> [GlobalReg]
realArgRegsCover Platform
platform
    | Platform -> Bool
passFloatArgsInXmm Platform
platform
    = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ VGcPtr
VGcPtr) (Platform -> [VGcPtr -> GlobalReg]
realVanillaRegs Platform
platform) forall a. [a] -> [a] -> [a]
++
      Platform -> [GlobalReg]
realLongRegs Platform
platform forall a. [a] -> [a] -> [a]
++
      Platform -> [GlobalReg]
realDoubleRegs Platform
platform -- we only need to save the low Double part of XMM registers.
                              -- Moreover, the NCG can't load/store full XMM
                              -- registers for now...

    | Bool
otherwise
    = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ VGcPtr
VGcPtr) (Platform -> [VGcPtr -> GlobalReg]
realVanillaRegs Platform
platform) forall a. [a] -> [a] -> [a]
++
      Platform -> [GlobalReg]
realFloatRegs  Platform
platform forall a. [a] -> [a] -> [a]
++
      Platform -> [GlobalReg]
realDoubleRegs Platform
platform forall a. [a] -> [a] -> [a]
++
      Platform -> [GlobalReg]
realLongRegs   Platform
platform
      -- we don't save XMM registers if they are not used for parameter passing

-- Like realArgRegsCover but always includes the node. This covers the real
-- and virtual registers used for unboxed tuples.
--
-- Note: if anything changes in how registers for unboxed tuples overlap,
--       make sure to also update GHC.StgToByteCode.layoutTuple.

tupleRegsCover :: Platform -> [GlobalReg]
tupleRegsCover :: Platform -> [GlobalReg]
tupleRegsCover Platform
platform =
  forall a. Eq a => [a] -> [a]
nub (Int -> VGcPtr -> GlobalReg
VanillaReg Int
1 VGcPtr
VGcPtr forall a. a -> [a] -> [a]
: Platform -> [GlobalReg]
realArgRegsCover Platform
platform)