Verified Commit c49250d8 authored by Moritz Angermann's avatar Moritz Angermann
Browse files

[CCall] carry signature from desugar to codegen

This is needed so that the codegen can produce C ABI calls
that require knowledge about the actual size of arguments.

Specifically aarch64-darwin will require arguments (in exess
of available registers) to be passed *packed* on the stack.
parent 5109e87e
......@@ -52,6 +52,8 @@ import DynFlags
import Control.Monad
import TyCon (PrimRep (..))
------------------------------------------------------------------------
-- Top-level bindings
------------------------------------------------------------------------
......@@ -716,9 +718,9 @@ link_caf node = do
; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
ForeignLabelInExternalPackage IsFunction
; bh <- newTemp (bWord dflags)
; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
[ (baseExpr, AddrHint),
(CmmReg (CmmLocal node), AddrHint) ]
; emitRtsCallGen [(bh, AddrRep, AddrHint)] newCAF_lbl
[ (baseExpr, AddrRep, AddrHint),
(CmmReg (CmmLocal node), AddrRep, AddrHint) ]
False
-- see Note [atomic CAF entry] in rts/sm/Storage.c
......
......@@ -571,7 +571,7 @@ isSimpleScrut _ _ = return False
isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
-- True iff the op cannot block or allocate
isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe _ _)) _) _ = return $! not (playSafe safe)
-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp
isSimpleOp (StgPrimOp DataToTagOp) _ = return False
isSimpleOp (StgPrimOp op) stg_args = do
......
......@@ -65,7 +65,7 @@ cgForeignCall :: ForeignCall -- the op
-> Type -- result type
-> FCode ReturnKind
cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
cgForeignCall (CCall (CCallSpec target cconv safety ret_rep arg_reps)) typ stg_args res_ty
= do { dflags <- getDynFlags
; let -- in the stdcall calling convention, the symbol needs @size appended
-- to it, where size is the total number of bytes of arguments. We
......@@ -97,7 +97,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
DynamicTarget -> case cmm_args of
(fn,_):rest -> (unzip rest, fn)
[] -> panic "cgForeignCall []"
fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn
fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn ret_rep arg_reps
call_target = ForeignTarget cmm_target fc
-- we want to emit code for the call, and then emitReturn.
......@@ -188,17 +188,22 @@ continuation, resulting in just one proc point instead of two. Yay!
-}
emitCCall :: [(CmmFormal,ForeignHint)]
emitCCall :: [(CmmFormal, PrimRep, ForeignHint)]
-> CmmExpr
-> [(CmmActual,ForeignHint)]
-> [(CmmActual, PrimRep, ForeignHint)]
-> FCode ()
emitCCall hinted_results fn hinted_args
= void $ emitForeignCall PlayRisky results target args
where
(args, arg_hints) = unzip hinted_args
(results, result_hints) = unzip hinted_results
(args, arg_reps, arg_hints) = unzip3 hinted_args
(results, result_reps, result_hints) = unzip3 hinted_results
-- extract result, we can only deal with 0 or 1 result types.
res_rep = case result_reps of
[] -> VoidRep
[r] -> r
_ -> error "can not deal with multiple return values in emitCCall"
target = ForeignTarget fn fc
fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn
fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn res_rep arg_reps
emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
......@@ -653,4 +658,3 @@ typeToStgFArgType typ
-- a type in a foreign function signature with a representationally
-- equivalent newtype.
tycon = tyConAppTyCon (unwrapType typ)
......@@ -290,15 +290,16 @@ emitPrimOp dflags = \case
-> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
-- First we handle various awkward cases specially.
-- First we handle various awkward cases specially.
-- Note: StgInt newSpark (StgRegTable *reg, StgClosure *p)
-- StgInt is Int_64 on 64bit platforms, Int_32 on others
ParOp -> \[arg] -> opAllDone $ \[res] -> do
-- for now, just implement this in a C function
-- later, we might want to inline it.
emitCCall
[(res,NoHint)]
[(res, Int64Rep, SignedHint)]
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
[(baseExpr, AddrHint), (arg,AddrHint)]
[(baseExpr, AddrRep, AddrHint), (arg, AddrRep, AddrHint)]
SparkOp -> \[arg] -> opAllDone $ \[res] -> do
-- returns the value of arg in res. We're going to therefore
......@@ -307,9 +308,9 @@ emitPrimOp dflags = \case
tmp <- assignTemp arg
tmp2 <- newTemp (bWord dflags)
emitCCall
[(tmp2,NoHint)]
[(tmp2, Int64Rep, SignedHint)]
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
[(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
[(baseExpr, AddrRep, AddrHint), ((CmmReg (CmmLocal tmp)), AddrRep, AddrHint)]
emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
GetCCSOfOp -> \[arg] -> opAllDone $ \[res] -> do
......@@ -342,7 +343,7 @@ emitPrimOp dflags = \case
emitCCall
[{-no results-}]
(CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
[(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]
[(baseExpr, AddrRep, AddrHint), (mutv, AddrRep, AddrHint), (CmmReg old_val, AddrRep, AddrHint)]
-- #define sizzeofByteArrayzh(r,a) \
-- r = ((StgArrBytes *)(a))->bytes
......
......@@ -44,6 +44,8 @@ import Outputable
import Control.Monad
import Data.Char (ord)
import TyCon (PrimRep (..))
-----------------------------------------------------------------------------
--
-- Cost-centre-stack Profiling
......@@ -178,8 +180,8 @@ enterCostCentreFun ccs closure =
if isCurrentCCS ccs
then do dflags <- getDynFlags
emitRtsCall rtsUnitId (fsLit "enterFunCCS")
[(baseExpr, AddrHint),
(costCentreFrom dflags closure, AddrHint)] False
[(baseExpr, AddrRep, AddrHint),
(costCentreFrom dflags closure, AddrRep, AddrHint)] False
else return () -- top-level function, nothing to do
ifProfiling :: FCode () -> FCode ()
......@@ -278,10 +280,10 @@ emitSetCCC cc tick push
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre result ccs cc
= emitRtsCallWithResult result AddrHint
= emitRtsCallWithResult result AddrRep AddrHint
rtsUnitId
(fsLit "pushCostCentre") [(ccs,AddrHint),
(CmmLit (mkCCostCentre cc), AddrHint)]
(fsLit "pushCostCentre") [(ccs, AddrRep, AddrHint),
(CmmLit (mkCCostCentre cc), AddrRep, AddrHint)]
False
bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
......
......@@ -179,19 +179,19 @@ tagToClosure dflags tycon tag
--
-------------------------------------------------------------------------
emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall :: UnitId -> FastString -> [(CmmExpr, PrimRep, ForeignHint)] -> Bool -> FCode ()
emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult res hint pkg fun args safe
= emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
emitRtsCallWithResult :: LocalReg -> PrimRep -> ForeignHint -> UnitId -> FastString
-> [(CmmExpr, PrimRep, ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult res rep hint pkg fun args safe
= emitRtsCallGen [(res, rep, hint)] (mkCmmCodeLabel pkg fun) args safe
-- Make a call to an RTS C procedure
emitRtsCallGen
:: [(LocalReg,ForeignHint)]
:: [(LocalReg, PrimRep, ForeignHint)]
-> CLabel
-> [(CmmExpr,ForeignHint)]
-> [(CmmExpr, PrimRep, ForeignHint)]
-> Bool -- True <=> CmmSafe call
-> FCode ()
emitRtsCallGen res lbl args safe
......@@ -206,10 +206,14 @@ emitRtsCallGen res lbl args safe
if safe then
emit =<< mkCmmCall fun_expr res' args' updfr_off
else do
let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn res_rep arg_reps
emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
(args', arg_hints) = unzip args
(res', res_hints) = unzip res
(args', arg_reps, arg_hints) = unzip3 args
(res', res_reps, res_hints) = unzip3 res
res_rep = case res_reps of
[] -> VoidRep
[r] -> r
_ -> error "can not deal with multiple return values"
fun_expr = mkLblExpr lbl
......@@ -608,8 +612,8 @@ emitUpdRemSetPush ptr = do
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushClosure_")
[(CmmReg (CmmGlobal BaseReg), AddrHint),
(ptr, AddrHint)]
[(CmmReg (CmmGlobal BaseReg), AddrRep, AddrHint),
(ptr, AddrRep, AddrHint)]
False
emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk
......@@ -618,6 +622,6 @@ emitUpdRemSetPushThunk ptr = do
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushThunk_")
[(CmmReg (CmmGlobal BaseReg), AddrHint),
(ptr, AddrHint)]
[(CmmReg (CmmGlobal BaseReg), AddrRep, AddrHint),
(ptr, AddrRep, AddrHint)]
False
......@@ -37,6 +37,7 @@ import Control.Monad.Fix
import Data.Array as Array
import Data.Bits
import Data.List (nub)
import TyCon (PrimRep (..))
{- Note [Stack Layout]
......@@ -1185,18 +1186,20 @@ lowerSafeForeignCall dflags block
foreignLbl :: FastString -> CmmExpr
foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
-- void * suspendThread (StgRegTable *, bool interruptible);
callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread dflags id intrbl =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "suspendThread"))
(ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
(ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn AddrRep [AddrRep, Word32Rep]))
[id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]
-- StgRegTable * resumeThread (void *);
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "resumeThread"))
(ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))
(ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn AddrRep [AddrRep]))
[new_base] [CmmReg (CmmLocal id)]
-- -----------------------------------------------------------------------------
......
......@@ -17,7 +17,7 @@ module CmmMachOp
, mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
-- CallishMachOp
, CallishMachOp(..), callishMachOpHints
, CallishMachOp(..), callishMachOpHints, callishMachOpReps
, pprCallishMachOp
, machOpMemcpyishAlign
......@@ -32,6 +32,8 @@ import CmmType
import Outputable
import DynFlags
import TyCon (PrimRep (..))
-----------------------------------------------------------------------------
-- MachOp
-----------------------------------------------------------------------------
......@@ -649,13 +651,93 @@ pprCallishMachOp mo = text (show mo)
callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])
callishMachOpHints op = case op of
MO_Memcpy _ -> ([], [AddrHint,AddrHint,NoHint])
MO_Memset _ -> ([], [AddrHint,NoHint,NoHint])
MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])
-- void * memcpy(void *restrict dst, const void *restrict src, size_t n);
MO_Memcpy _ -> ([], [AddrHint, AddrHint, NoHint])
-- void * memset(void *b, int c, size_t len);
MO_Memset _ -> ([], [AddrHint, SignedHint, NoHint])
-- void * memmove(void *dst, const void *src, size_t len);
MO_Memmove _ -> ([], [AddrHint, AddrHint, NoHint])
-- int memcmp(const void *s1, const void *s2, size_t n);
MO_Memcmp _ -> ([], [AddrHint, AddrHint, NoHint])
_ -> ([],[])
-- empty lists indicate NoHint
callishMachOpReps :: CallishMachOp -> (PrimRep, [PrimRep])
callishMachOpReps op = case op of
MO_Memcpy _ -> (AddrRep, [AddrRep, AddrRep, WordRep])
MO_Memset _ -> (AddrRep, [AddrRep, IntRep, WordRep])
MO_Memmove _ -> (AddrRep, [AddrRep, AddrRep, WordRep])
MO_Memcmp _ -> (IntRep, [AddrRep, AddrRep, WordRep])
MO_F64_Pwr -> (DoubleRep, [DoubleRep, DoubleRep])
MO_F64_Sin -> (DoubleRep, [DoubleRep])
MO_F64_Cos -> (DoubleRep, [DoubleRep])
MO_F64_Tan -> (DoubleRep, [DoubleRep])
MO_F64_Sinh -> (DoubleRep, [DoubleRep])
MO_F64_Cosh -> (DoubleRep, [DoubleRep])
MO_F64_Tanh -> (DoubleRep, [DoubleRep])
MO_F64_Asin -> (DoubleRep, [DoubleRep])
MO_F64_Acos -> (DoubleRep, [DoubleRep])
MO_F64_Atan -> (DoubleRep, [DoubleRep])
MO_F64_Asinh -> (DoubleRep, [DoubleRep])
MO_F64_Acosh -> (DoubleRep, [DoubleRep])
MO_F64_Atanh -> (DoubleRep, [DoubleRep])
MO_F64_Log -> (DoubleRep, [DoubleRep])
MO_F64_Log1P -> (DoubleRep, [DoubleRep])
MO_F64_Exp -> (DoubleRep, [DoubleRep])
MO_F64_ExpM1 -> (DoubleRep, [DoubleRep])
MO_F64_Fabs -> (DoubleRep, [DoubleRep])
MO_F64_Sqrt -> (DoubleRep, [DoubleRep])
MO_F32_Pwr -> (FloatRep, [FloatRep, FloatRep])
MO_F32_Sin -> (FloatRep, [FloatRep])
MO_F32_Cos -> (FloatRep, [FloatRep])
MO_F32_Tan -> (FloatRep, [FloatRep])
MO_F32_Sinh -> (FloatRep, [FloatRep])
MO_F32_Cosh -> (FloatRep, [FloatRep])
MO_F32_Tanh -> (FloatRep, [FloatRep])
MO_F32_Asin -> (FloatRep, [FloatRep])
MO_F32_Acos -> (FloatRep, [FloatRep])
MO_F32_Atan -> (FloatRep, [FloatRep])
MO_F32_Asinh -> (FloatRep, [FloatRep])
MO_F32_Acosh -> (FloatRep, [FloatRep])
MO_F32_Atanh -> (FloatRep, [FloatRep])
MO_F32_Log -> (FloatRep, [FloatRep])
MO_F32_Log1P -> (FloatRep, [FloatRep])
MO_F32_Exp -> (FloatRep, [FloatRep])
MO_F32_ExpM1 -> (FloatRep, [FloatRep])
MO_F32_Fabs -> (FloatRep, [FloatRep])
MO_F32_Sqrt -> (FloatRep, [FloatRep])
MO_PopCnt W8 -> (Word8Rep, [Word8Rep])
MO_PopCnt W16 -> (Word16Rep, [Word16Rep])
MO_PopCnt W32 -> (Word32Rep, [Word32Rep])
MO_PopCnt W64 -> (Word64Rep, [Word64Rep])
MO_BSwap W8 -> (Word8Rep, [Word8Rep])
MO_BSwap W16 -> (Word16Rep, [Word16Rep])
MO_BSwap W32 -> (Word32Rep, [Word32Rep])
MO_BSwap W64 -> (Word64Rep, [Word64Rep])
MO_BRev W8 -> (Word8Rep, [Word8Rep])
MO_BRev W16 -> (Word16Rep, [Word16Rep])
MO_BRev W32 -> (Word32Rep, [Word32Rep])
MO_BRev W64 -> (Word64Rep, [Word64Rep])
_ -> (VoidRep, [])
-- | The alignment of a 'memcpy'-ish operation.
machOpMemcpyishAlign :: CallishMachOp -> Maybe Int
machOpMemcpyishAlign op = case op of
......
......@@ -9,13 +9,12 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- CmmNode type for representation using Hoopl graphs.
module CmmNode (
CmmNode(..), CmmFormal, CmmActual, CmmTickish,
UpdFrameOffset, Convention(..),
ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
ForeignConvention(..), ForeignTarget(..), foreignTargetHints, foreignTargetReps,
CmmReturnInfo(..),
mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,
......@@ -46,6 +45,7 @@ import Data.List (tails,sortBy)
import Unique (nonDetCmpUnique)
import Util
import TyCon (PrimRep)
------------------------
-- CmmNode
......@@ -281,12 +281,36 @@ data Convention
-- (TODO: I don't think we need this --SDM)
deriving( Eq )
--------------------------------------------------
-- Note [ForeignConvention PrimRep Carry]
--
-- With the advert of aarch64-darwin, a new AAPCS was brought into mainstream.
-- This AAPCS requires us to pack arguments in excess of registers by their
-- size on the stack as well as extends values as necessary.
--
-- GHC's internal represetnation of values ends up being either Words or Ints,
-- both of which are assumed to be Word size[1]. Thus in the CodeGen there is no
-- way to recover the origial size of arguments.
--
-- In GHC 9.2 this has been rectified in !4390 (commit 3e3555cc); however for
-- GHCs before 9.2 to support aarch64-darwin, we need a more lightweight solution.
-- Thus we inject the PrimRep signature during the desugar phase into the
-- ForeignConvention and carry it through to the CodeGen where we can inspect
-- it and produce the correct ABI calls.
--
-- See https://developer.apple.com/documentation/xcode/writing_arm64_code_for_apple_platforms
--
-- [1]: Int8 = I8# Int#, Word8 = W8# Word#
data ForeignConvention
= ForeignConvention
CCallConv -- Which foreign-call convention
[ForeignHint] -- Extra info about the args
[ForeignHint] -- Extra info about the result
CmmReturnInfo
PrimRep -- return prim rep
[PrimRep] -- argument prim reps
deriving Eq
data CmmReturnInfo
......@@ -302,7 +326,11 @@ data ForeignTarget -- The target of a foreign call
CallishMachOp -- Which one
deriving Eq
foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetReps :: HasCallStack => ForeignTarget -> (PrimRep, [PrimRep])
foreignTargetReps (ForeignTarget _ (ForeignConvention _ _ _ _ rr ras)) = (rr, ras)
foreignTargetReps (PrimTarget op) = callishMachOpReps op
foreignTargetHints :: HasCallStack => ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints target
= ( res_hints ++ repeat NoHint
, arg_hints ++ repeat NoHint )
......@@ -310,7 +338,7 @@ foreignTargetHints target
(res_hints, arg_hints) =
case target of
PrimTarget op -> callishMachOpHints op
ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
ForeignTarget _ (ForeignConvention _ arg_hints res_hints _ _ _) ->
(res_hints, arg_hints)
--------------------------------------------------
......@@ -376,7 +404,7 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where
activeRegs = activeStgRegs platform
activeCallerSavesRegs = filter (callerSaves platform) activeRegs
foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns _ _)) = []
foreignTargetRegs _ = activeCallerSavesRegs
-- Note [Safe foreign calls clobber STG registers]
......
......@@ -262,6 +262,8 @@ import Data.Maybe
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as BS8
import TyCon (PrimRep(..))
#include "HsVersions.h"
}
......@@ -1203,7 +1205,27 @@ foreignCall conv_string results_code expr_code args_code safety ret
expr' = adjCallTarget dflags conv expr args
(arg_exprs, arg_hints) = unzip args
(res_regs, res_hints) = unzip results
fc = ForeignConvention conv arg_hints res_hints ret
res_cmm_tys = zip (map localRegType res_regs) res_hints
arg_cmm_tys = zip (map (cmmExprType dflags) arg_exprs) arg_hints
res_rep :: (CmmType, ForeignHint) -> PrimRep
res_rep (_, AddrHint) = AddrRep
res_rep (t, _) | isGcPtrType t = Word64Rep
res_rep (t, SignedHint) | t `cmmEqType` b8 = Int8Rep
res_rep (t, SignedHint) | t `cmmEqType` b16 = Int16Rep
res_rep (t, SignedHint) | t `cmmEqType` b32 = Int32Rep
res_rep (t, SignedHint) | t `cmmEqType` b64 = Int64Rep
res_rep (t, NoHint) | t `cmmEqType` b8 = Word8Rep
res_rep (t, NoHint) | t `cmmEqType` b16 = Word16Rep
res_rep (t, NoHint) | t `cmmEqType` b32 = Word32Rep
res_rep (t, NoHint) | t `cmmEqType` b64 = Word64Rep
res_rep (t, _) | t `cmmEqType` f32 = FloatRep
res_rep (t, _) | t `cmmEqType` f64 = DoubleRep
ret_rep = case (map res_rep res_cmm_tys) of
[] -> VoidRep
[r] -> r
x -> (panic $ show x)
fc = ForeignConvention conv arg_hints res_hints ret ret_rep (map res_rep arg_cmm_tys)
target = ForeignTarget expr' fc
_ <- code $ emitForeignCall safety res_regs target arg_exprs
return ()
......
......@@ -11,7 +11,7 @@
module CmmUtils(
-- CmmType
primRepCmmType, slotCmmType, slotForeignHint,
primRepCmmType, slotCmmType,
typeCmmType, typeForeignHint, primRepForeignHint,
-- CmmLit
......@@ -156,13 +156,6 @@ primRepForeignHint FloatRep = NoHint
primRepForeignHint DoubleRep = NoHint
primRepForeignHint (VecRep {}) = NoHint
slotForeignHint :: SlotTy -> ForeignHint
slotForeignHint PtrSlot = AddrHint
slotForeignHint WordSlot = NoHint
slotForeignHint Word64Slot = NoHint
slotForeignHint FloatSlot = NoHint
slotForeignHint DoubleSlot = NoHint
typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint = primRepForeignHint . typePrimRep1
......
......@@ -235,7 +235,7 @@ pprStmt stmt =
hresults = zip results res_hints
hargs = zip args arg_hints
ForeignConvention cconv _ _ ret = conv
ForeignConvention cconv _ _ ret _ _ = conv
cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
......
......@@ -155,7 +155,7 @@ pprConvention Slow = text "<slow-convention>"
pprConvention GC = text "<gc-convention>"
pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention c args res ret) =
pprForeignConvention (ForeignConvention c args res ret _ _) =
doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
pprReturnInfo :: CmmReturnInfo -> SDoc
......
......@@ -47,6 +47,7 @@ import Util
import Data.Maybe
import RepType (mkCCallSpec)
{-
Desugaring of @ccall@s consists of adding some state manipulation,
unboxing any boxed primitive arguments and boxing the result if
......@@ -97,8 +98,14 @@ dsCCall lbl args may_gc result_ty
uniq <- newUnique
dflags <- getDynFlags
let
arg_tys = map exprType args
raw_res_ty = case tcSplitIOType_maybe result_ty of
Just (_ioTyCon, res_ty) -> res_ty
Nothing -> result_ty
target = StaticTarget NoSourceText lbl Nothing True
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_fcall = CCall (mkCCallSpec target CCallConv may_gc raw_res_ty arg_tys)
the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
......
......@@ -173,9 +173,13 @@ dsCImport id co (CLabel cid) cconv _ _ = do
return ([(id, rhs')], empty, empty)
dsCImport id co (CFunction target) cconv@PrimCallConv safety _
= dsPrimCall id co (CCall (CCallSpec target cconv safety))
= dsPrimCall id co (CCall (mkCCallSpec target cconv safety
(panic "Missing Return PrimRep")
(panic "Missing Argument PrimReps")))
dsCImport id co (CFunction target) cconv safety mHeader
= dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
= dsFCall id co (CCall (mkCCallSpec target cconv safety
(panic "Missing Return PrimRep")
(panic "Missing Argument PrimReps"))) mHeader
dsCImport id co CWrapper cconv _ _
= dsFExportDynamic id co cconv
......@@ -203,7 +207,7 @@ fun_type_arg_stdcall_info _ _other_conv _
dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id co fcall mDeclHeader = do
dsFCall fn_id co (CCall (CCallSpec target cconv safety _ _)) mDeclHeader = do
let
ty = pFst $ coercionKind co
(tv_bndrs, rho) = tcSplitForAllVarBndrs ty
......@@ -221,16 +225,19 @@ dsFCall fn_id co fcall mDeclHeader = do
work_uniq <- newUnique
dflags <- getDynFlags
(fcall', cDoc) <-
case fcall of
let
fcall = CCall (mkCCallSpec target cconv safety io_res_ty arg_tys)
(fcall', cDoc) <- case fcall of
CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
CApiConv safety) ->
CApiConv safety _ _) ->
do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)