Commit 36f8cabe authored by Ian Lynagh's avatar Ian Lynagh

Implement a capi calling convention; fixes #2979

In GHC, this provides an easy way to call a C function via a C wrapper.
This is important when the function is really defined by CPP.

Requires the new CApiFFI extension.

Not documented yet, as it's still an experimental feature at this stage.
parent 825e0a3e
......@@ -845,6 +845,7 @@ pprCall platform ppr_fn cconv results args _
-- change in the future...
is_cishCC :: CCallConv -> Bool
is_cishCC CCallConv = True
is_cishCC CApiConv = True
is_cishCC StdCallConv = True
is_cishCC CmmCallConv = False
is_cishCC PrimCallConv = False
......
......@@ -125,8 +125,8 @@ dsFImport :: Id
-> Coercion
-> ForeignImport
-> DsM ([Binding], SDoc, SDoc)
dsFImport id co (CImport cconv safety _ spec) = do
(ids, h, c) <- dsCImport id co spec cconv safety
dsFImport id co (CImport cconv safety header spec) = do
(ids, h, c) <- dsCImport id co spec cconv safety header
return (ids, h, c)
dsCImport :: Id
......@@ -134,8 +134,9 @@ dsCImport :: Id
-> CImportSpec
-> CCallConv
-> Safety
-> FastString -- header
-> DsM ([Binding], SDoc, SDoc)
dsCImport id co (CLabel cid) cconv _ = do
dsCImport id co (CLabel cid) cconv _ _ = do
let ty = pFst $ coercionKind co
fod = case tyConAppTyCon_maybe ty of
Just tycon
......@@ -151,11 +152,11 @@ dsCImport id co (CLabel cid) cconv _ = do
in
return ([(id, rhs')], empty, empty)
dsCImport id co (CFunction target) cconv@PrimCallConv safety
dsCImport id co (CFunction target) cconv@PrimCallConv safety _
= dsPrimCall id co (CCall (CCallSpec target cconv safety))
dsCImport id co (CFunction target) cconv safety
= dsFCall id co (CCall (CCallSpec target cconv safety))
dsCImport id co CWrapper cconv _
dsCImport id co (CFunction target) cconv safety header
= dsFCall id co (CCall (CCallSpec target cconv safety)) header
dsCImport id co CWrapper cconv _ _
= dsFExportDynamic id co cconv
-- For stdcall labels, if the type was a FunPtr or newtype thereof,
......@@ -181,8 +182,9 @@ fun_type_arg_stdcall_info _other_conv _
%************************************************************************
\begin{code}
dsFCall :: Id -> Coercion -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id co fcall = do
dsFCall :: Id -> Coercion -> ForeignCall -> FastString
-> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id co fcall headerFilename = do
let
ty = pFst $ coercionKind co
(tvs, fun_ty) = tcSplitForAllTys ty
......@@ -200,10 +202,48 @@ dsFCall fn_id co fcall = do
ccall_uniq <- newUnique
work_uniq <- newUnique
(fcall', cDoc) <-
case fcall of
CCall (CCallSpec (StaticTarget cName mPackageId) CApiConv safety) ->
do fcall_uniq <- newUnique
let wrapperName = mkFastString "ghc_wrapper_" `appendFS`
mkFastString (showSDoc (ppr fcall_uniq)) `appendFS`
mkFastString "_" `appendFS`
cName
fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId) CApiConv safety)
c = include
$$ fun_proto <+> braces (cRet <> semi)
include
| nullFS headerFilename = empty
| otherwise = text "#include <" <> ftext headerFilename <> text ">"
fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
cRet
| isVoidRes = cCall
| otherwise = text "return" <+> cCall
cCall = ppr cName <> parens argVals
raw_res_ty = case tcSplitIOType_maybe io_res_ty of
Just (_ioTyCon, res_ty) -> res_ty
Nothing -> io_res_ty
isVoidRes = raw_res_ty `eqType` unitTy
cResType | isVoidRes = text "void"
| otherwise = showStgType raw_res_ty
pprCconv = ccallConvAttribute CApiConv
argTypes
| null arg_tys = text "void"
| otherwise = hsep $ punctuate comma
[ showStgType t <+> char 'a' <> int n
| (t, n) <- zip arg_tys [1..] ]
argVals = hsep $ punctuate comma
[ char 'a' <> int n
| (_, n) <- zip arg_tys [1..] ]
return (fcall', c)
_ ->
return (fcall, empty)
let
-- Build the worker
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
......@@ -214,7 +254,7 @@ dsFCall fn_id co fcall = do
wrap_rhs' = Cast wrap_rhs co
fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, empty)
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
\end{code}
......
......@@ -239,6 +239,7 @@ genCall env target res args ret = do
ArchX86_64 -> CC_X86_Stdcc
_ -> CC_Ccc
CCallConv -> CC_Ccc
CApiConv -> CC_Ccc
PrimCallConv -> CC_Ccc
CmmCallConv -> panic "CmmCallConv not supported here!"
......
......@@ -378,6 +378,7 @@ data ExtensionFlag
| Opt_ForeignFunctionInterface
| Opt_UnliftedFFITypes
| Opt_InterruptibleFFI
| Opt_CApiFFI
| Opt_GHCForeignImportPrim
| Opt_ParallelArrays -- Syntactic support for parallel arrays
| Opt_Arrows -- Arrow-notation syntax
......@@ -1898,6 +1899,7 @@ xFlags = [
( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ),
( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ),
( "InterruptibleFFI", Opt_InterruptibleFFI, nop ),
( "CApiFFI", Opt_CApiFFI, nop ),
( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ),
( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ),
( "Rank2Types", Opt_Rank2Types, nop ),
......
......@@ -457,6 +457,7 @@ data Token
| ITunsafe
| ITstdcallconv
| ITccallconv
| ITcapiconv
| ITprimcallconv
| ITmdo
| ITfamily
......@@ -642,6 +643,7 @@ reservedWordsFM = listToUFM $
( "unsafe", ITunsafe, bit ffiBit),
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "capi", ITcapiconv, bit cApiFfiBit),
( "prim", ITprimcallconv, bit ffiBit),
( "rec", ITrec, bit recBit),
......@@ -1754,6 +1756,8 @@ ffiBit :: Int
ffiBit= 0
interruptibleFfiBit :: Int
interruptibleFfiBit = 1
cApiFfiBit :: Int
cApiFfiBit = 2
parrBit :: Int
parrBit = 3
arrowsBit :: Int
......@@ -1879,6 +1883,7 @@ mkPState flags buf loc =
where
bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
.|. interruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags
.|. cApiFfiBit `setBitIf` xopt Opt_CApiFFI flags
.|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
.|. arrowsBit `setBitIf` xopt Opt_Arrows flags
.|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
......
......@@ -244,6 +244,7 @@ incorrect.
'family' { L _ ITfamily }
'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv }
'capi' { L _ ITcapiconv }
'prim' { L _ ITprimcallconv }
'proc' { L _ ITproc } -- for arrow notation extension
'rec' { L _ ITrec } -- for arrow notation extension
......@@ -922,6 +923,7 @@ fdecl : 'import' callconv safety fspec
callconv :: { CCallConv }
: 'stdcall' { StdCallConv }
| 'ccall' { CCallConv }
| 'capi' { CApiConv }
| 'prim' { PrimCallConv}
safety :: { Safety }
......@@ -1945,6 +1947,7 @@ special_id
| 'dynamic' { L1 (fsLit "dynamic") }
| 'stdcall' { L1 (fsLit "stdcall") }
| 'ccall' { L1 (fsLit "ccall") }
| 'capi' { L1 (fsLit "capi") }
| 'prim' { L1 (fsLit "prim") }
| 'group' { L1 (fsLit "group") }
......
......@@ -151,13 +151,15 @@ platforms.
See: http://www.programmersheaven.com/2/Calling-conventions
\begin{code}
data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
data CCallConv = CCallConv | CApiConv | StdCallConv
| CmmCallConv | PrimCallConv
deriving (Eq, Data, Typeable)
{-! derive: Binary !-}
instance Outputable CCallConv where
ppr StdCallConv = ptext (sLit "stdcall")
ppr CCallConv = ptext (sLit "ccall")
ppr CApiConv = ptext (sLit "capi")
ppr CmmCallConv = ptext (sLit "C--")
ppr PrimCallConv = ptext (sLit "prim")
......@@ -167,6 +169,7 @@ defaultCCallConv = CCallConv
ccallConvToInt :: CCallConv -> Int
ccallConvToInt StdCallConv = 0
ccallConvToInt CCallConv = 1
ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv"
ccallConvToInt (CmmCallConv {}) = panic "ccallConvToInt CmmCallConv"
ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
\end{code}
......@@ -178,6 +181,7 @@ calling convention (used by PprAbsC):
ccallConvAttribute :: CCallConv -> SDoc
ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))"
ccallConvAttribute CCallConv = empty
ccallConvAttribute CApiConv = empty
ccallConvAttribute (CmmCallConv {}) = panic "ccallConvAttribute CmmCallConv"
ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
\end{code}
......@@ -294,11 +298,14 @@ instance Binary CCallConv where
putByte bh 2
put_ bh CmmCallConv = do
putByte bh 3
put_ bh CApiConv = do
putByte bh 4
get bh = do
h <- getByte bh
case h of
0 -> do return CCallConv
1 -> do return StdCallConv
2 -> do return PrimCallConv
_ -> do return CmmCallConv
3 -> do return CmmCallConv
_ -> do return CApiConv
\end{code}
......@@ -453,6 +453,7 @@ Calling conventions
\begin{code}
checkCConv :: CCallConv -> TcM ()
checkCConv CCallConv = return ()
checkCConv CApiConv = return ()
checkCConv StdCallConv = do dflags <- getDOpts
let platform = targetPlatform dflags
unless (platformArch platform == ArchX86) $
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment