Commit ae04bd43 authored by Ian Lynagh's avatar Ian Lynagh

Implement "value" imports with the CAPI

This allows us to import values (i.e. non-functions) with the CAPI.
This means we can access values even if (on some or all platforms)
they are simple #defines.
parent 9065bdbf
......@@ -78,9 +78,11 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
where
(call_args, cmm_target)
= case target of
StaticTarget _ _ False ->
panic "emitForeignCall: unexpected FFI value import"
-- If the packageId is Nothing then the label is taken to be in the
-- package currently being compiled.
StaticTarget lbl mPkgId
StaticTarget lbl mPkgId True
-> let labelSource
= case mPkgId of
Nothing -> ForeignLabelInThisPackage
......
......@@ -56,7 +56,9 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
= do { cmm_args <- getFCallArgs stg_args
; let ((call_args, arg_hints), cmm_target)
= case target of
StaticTarget lbl mPkgId
StaticTarget _ _ False ->
panic "cgForeignCall: unexpected FFI value import"
StaticTarget lbl mPkgId True
-> let labelSource
= case mPkgId of
Nothing -> ForeignLabelInThisPackage
......
......@@ -138,8 +138,10 @@ make_exp (Var v) = do
isLocal <- isALocal vName
return $
case idDetails v of
FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _))
FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _))
-> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
panic "make_exp: FFI values not supported"
FCallId (CCall (CCallSpec DynamicTarget callconv _))
-> C.DynExternal (showSDoc (ppr callconv)) (make_ty (varType v))
-- Constructors are always exported, so make sure to declare them
......
......@@ -98,7 +98,7 @@ dsCCall lbl args may_gc result_ty
(ccall_result_ty, res_wrapper) <- boxResult result_ty
uniq <- newUnique
let
target = StaticTarget lbl Nothing
target = StaticTarget lbl Nothing True
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
......
......@@ -207,13 +207,13 @@ dsFCall fn_id co fcall mDeclHeader = do
(fcall', cDoc) <-
case fcall of
CCall (CCallSpec (StaticTarget cName mPackageId) CApiConv safety) ->
CCall (CCallSpec (StaticTarget cName mPackageId isFun) 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)
fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety)
c = includes
$$ fun_proto <+> braces (cRet <> semi)
includes = vcat [ text "#include <" <> ftext h <> text ">"
......@@ -222,7 +222,11 @@ dsFCall fn_id co fcall mDeclHeader = do
cRet
| isVoidRes = cCall
| otherwise = text "return" <+> cCall
cCall = ppr cName <> parens argVals
cCall = if isFun
then ppr cName <> parens argVals
else if null arg_tys
then ppr cName
else panic "dsFCall: Unexpected arguments to FFI value import"
raw_res_ty = case tcSplitIOType_maybe io_res_ty of
Just (_ioTyCon, res_ty) -> res_ty
Nothing -> io_res_ty
......
......@@ -350,10 +350,11 @@ repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
where
conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
conv_cimportspec (CFunction (StaticTarget _ _ False)) = panic "conv_cimportspec: values not supported yet"
conv_cimportspec CWrapper = return "wrapper"
static = case cis of
CFunction (StaticTarget _ _) -> "static "
CFunction (StaticTarget _ _ _) -> "static "
_ -> ""
chStr = case mch of
Nothing -> ""
......
......@@ -986,7 +986,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
DynamicTarget
-> return (False, panic "ByteCodeGen.generateCCall(dyn)")
StaticTarget target _
StaticTarget _ _ False ->
panic "generateCCall: unexpected FFI value import"
StaticTarget target _ True
-> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
return (True, res)
where
......
......@@ -1024,8 +1024,11 @@ instance Outputable ForeignImport where
pprCEntity (CLabel lbl) =
ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
pprCEntity (CFunction (StaticTarget lbl _)) =
ptext (sLit "static") <+> pp_hdr <+> ppr lbl
pprCEntity (CFunction (StaticTarget lbl _ isFun)) =
ptext (sLit "static")
<+> pp_hdr
<+> (if isFun then empty else ptext (sLit "value"))
<+> ppr lbl
pprCEntity (CFunction (DynamicTarget)) =
ptext (sLit "dynamic")
pprCEntity (CWrapper) = ptext (sLit "wrapper")
......
......@@ -278,7 +278,7 @@ exp :: { IfaceExpr }
-- "InlineMe" -> IfaceNote IfaceInlineMe $3
-- }
| '%external' STRING aty { IfaceFCall (ForeignCall.CCall
(CCallSpec (StaticTarget (mkFastString $2) Nothing)
(CCallSpec (StaticTarget (mkFastString $2) Nothing True)
CCallConv PlaySafe))
$3 }
......
......@@ -914,7 +914,7 @@ mkImport :: CCallConv
-> P (HsDecl RdrName)
mkImport cconv safety (L loc entity, v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget entity Nothing)
let funcTarget = CFunction (StaticTarget entity Nothing True)
importSpec = CImport PrimCallConv safety Nothing funcTarget
return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
......@@ -937,9 +937,11 @@ parseCImport cconv safety nm str =
r <- choice [
string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
string "wrapper" >> return (mk Nothing CWrapper),
optional (token "static" >> skipSpaces) >>
(mk Nothing <$> cimp nm) +++
(do h <- munch1 hdr_char; skipSpaces; mk (Just (Header (mkFastString h))) <$> cimp nm)
do optional (token "static" >> skipSpaces)
((mk Nothing <$> cimp nm) +++
(do h <- munch1 hdr_char
skipSpaces
mk (Just (Header (mkFastString h))) <$> cimp nm))
]
skipSpaces
return r
......@@ -960,7 +962,15 @@ parseCImport cconv safety nm str =
id_char c = isAlphaNum c || c == '_'
cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
+++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
+++ (do isFun <- case cconv of
CApiConv ->
option True
(do token "value"
skipSpaces
return False)
_ -> return True
cid' <- cid
return (CFunction (StaticTarget cid' Nothing isFun)))
where
cid = return nm +++
(do c <- satisfy id_first_char
......
......@@ -127,6 +127,9 @@ data CCallTarget
-- The first argument of the import is the name of a function pointer (an Addr#).
-- Used when importing a label as "foreign import ccall "dynamic" ..."
Bool -- True => really a function
-- False => a value; only
-- allowed in CAPI imports
| DynamicTarget
deriving( Eq, Data, Typeable )
......@@ -219,11 +222,14 @@ instance Outputable CCallSpec where
gc_suf | playSafe safety = text "_GC"
| otherwise = empty
ppr_fun (StaticTarget fn Nothing)
= text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
ppr_fun (StaticTarget fn (Just pkgId))
= text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
ppr_fun (StaticTarget fn mPkgId isFun)
= text (if isFun then "__pkg_ccall"
else "__pkg_ccall_value")
<> gc_suf
<+> (case mPkgId of
Nothing -> empty
Just pkgId -> ppr pkgId)
<+> pprCLabelString fn
ppr_fun DynamicTarget
= text "__dyn_ccall" <> gc_suf <+> text "\"\""
......@@ -297,10 +303,11 @@ instance Binary CCallSpec where
return (CCallSpec aa ab ac)
instance Binary CCallTarget where
put_ bh (StaticTarget aa ab) = do
put_ bh (StaticTarget aa ab ac) = do
putByte bh 0
put_ bh aa
put_ bh ab
put_ bh ac
put_ bh DynamicTarget = do
putByte bh 1
get bh = do
......@@ -308,7 +315,8 @@ instance Binary CCallTarget where
case h of
0 -> do aa <- get bh
ab <- get bh
return (StaticTarget aa ab)
ac <- get bh
return (StaticTarget aa ab ac)
_ -> do return DynamicTarget
instance Binary CCallConv where
......
......@@ -407,8 +407,8 @@ patchCImportSpec packageId spec
patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
patchCCallTarget packageId callTarget
= case callTarget of
StaticTarget label Nothing
-> StaticTarget label (Just packageId)
StaticTarget label Nothing isFun
-> StaticTarget label (Just packageId) isFun
_ -> callTarget
......
......@@ -545,7 +545,7 @@ coreToStgApp _ f args = do
StgOpApp (StgPrimOp op) args' res_ty
-- A call to some primitive Cmm function.
FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _))
-> ASSERT( saturated )
StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
......
......@@ -263,13 +263,18 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
checkMissingAmpersand dflags arg_tys res_ty
case target of
StaticTarget _ _ False
| not (null arg_tys) ->
addErrTc (text "`value' imports cannot have function types")
_ -> return ()
return idecl
-- This makes a convenient place to check
-- that the C identifier is valid for C
checkCTarget :: CCallTarget -> TcM ()
checkCTarget (StaticTarget str _) = do
checkCTarget (StaticTarget str _ _) = do
checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
check (isCLabelString str) (badCName str)
......
......@@ -169,8 +169,7 @@ foreign import ccall interruptible
declarations, e.g.
<programlisting>
foreign import capi
"header.h f" :: CInt -> IO CInt
foreign import capi "header.h f" f :: CInt -> IO CInt
</programlisting>
Rather than generating code to call <literal>f</literal>
......@@ -181,6 +180,25 @@ foreign import capi
<literal>#define</literal> rather than a proper function.
</para>
<para>
When using <literal>capi</literal>, it is also possible to
import values, rather than functions. For example,
<programlisting>
foreign import capi "pi.h pi" c_pi :: CDouble
</programlisting>
will work regardless of whether <literal>pi</literal> is
defined as
<programlisting>
const double pi = 3.14;
</programlisting>
or with
<programlisting>
#define pi 3.14
</programlisting>
</para>
<para>
In order to tell GHC the C type that a Haskell type
corresponds to when it is used with the CAPI, a
......
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