module CmmCallConv (
ParamLocation(..),
ArgumentFormat,
assignArguments,
assignArgumentsPos,
argumentsSize,
) where
#include "HsVersions.h"
import Cmm
import SMRep
import ZipCfgCmmRep (Convention(..))
import Constants
import qualified Data.List as L
import StaticFlags (opt_Unregisterised)
import Outputable
data ParamLocation a
= RegisterParam GlobalReg
| StackParam a
instance (Outputable a) => Outputable (ParamLocation a) where
ppr (RegisterParam g) = ppr g
ppr (StackParam p) = ppr p
type ArgumentFormat a b = [(a, ParamLocation b)]
assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff
assignArguments _ _ = panic "assignArguments only used in dead codegen"
assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] ->
ArgumentFormat a ByteOff
assignArgumentsPos conv arg_ty reps = assignments
where
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode
(_, NativeDirectCall) -> getRegsWithoutNode
([_], NativeReturn) -> allRegs
(_, NativeReturn) -> getRegsWithNode
(_, GC) -> getRegsWithNode
(_, PrimOpCall) -> allRegs
([_], PrimOpReturn) -> allRegs
(_, PrimOpReturn) -> getRegsWithNode
(_, Slow) -> noRegs
_ -> pprPanic "Unknown calling convention" (ppr conv)
(reg_assts, stk_args) = assign_regs [] reps regs
stk_args' = case conv of NativeReturn -> part
PrimOpReturn -> part
_ -> stk_args
where part = uncurry (++)
(L.partition (not . isGcPtrType . arg_ty) stk_args)
stk_assts = assign_stk 0 [] (reverse stk_args')
assignments = reg_assts ++ stk_assts
assign_regs assts [] _ = (assts, [])
assign_regs assts (r:rs) regs = if isFloatType ty then float else int
where float = case (w, regs) of
(W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls))
(W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls))
(W80, _) -> panic "F80 unsupported register type"
_ -> (assts, (r:rs))
int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type"
(_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth
-> k (RegisterParam (v gcp), (vs, fs, ds, ls))
(_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth
-> k (RegisterParam l, (vs, fs, ds, ls))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
ty = arg_ty r
w = typeWidth ty
gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
assign_stk _ assts [] = assts
assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
where w = typeWidth (arg_ty r)
size = (((widthInBytes w 1) `div` wORD_SIZE) + 1) * wORD_SIZE
off' = offset + size
argumentsSize :: (a -> CmmType) -> [a] -> WordOff
argumentsSize f reps = maximum (0 : map arg_top args)
where
args = assignArguments f reps
arg_top (_, StackParam offset) = offset
arg_top (_, RegisterParam _) = 0
type AvailRegs = ( [VGcPtr -> GlobalReg]
, [GlobalReg]
, [GlobalReg]
, [GlobalReg]
)
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
vanillaRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Vanilla_REG
floatRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Float_REG
doubleRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Double_REG
longRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Long_REG
getRegsWithoutNode, getRegsWithNode :: AvailRegs
getRegsWithoutNode =
(filter (\r -> r VGcPtr /= node) intRegs,
map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
where intRegs = map VanillaReg vanillaRegNos
getRegsWithNode =
(intRegs, map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
where intRegs = map VanillaReg vanillaRegNos
allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
allVanillaRegNos = regList mAX_Vanilla_REG
allFloatRegNos = regList mAX_Float_REG
allDoubleRegNos = regList mAX_Double_REG
allLongRegNos = regList mAX_Long_REG
regList :: Int -> [Int]
regList n = [1 .. n]
allRegs :: AvailRegs
allRegs = (map VanillaReg allVanillaRegNos, map FloatReg allFloatRegNos,
map DoubleReg allDoubleRegNos, map LongReg allLongRegNos)
noRegs :: AvailRegs
noRegs = ([], [], [], [])