module checks to see if a foreign declaration has got a legal type.
\begin{code}
-module TcForeign
- (
- tcForeignImports
+module TcForeign
+ (
+ tcForeignImports
, tcForeignExports
- ) where
+ ) where
#include "HsVersions.h"
import TcRnMonad
import TcHsType
import TcExpr
+import TcEnv
import ForeignCall
import ErrUtils
import Id
-#if alpha_TARGET_ARCH
-import Type
-import SMRep
-import MachOp
-#endif
import Name
import TcType
import DynFlags
import Outputable
import SrcLoc
import Bag
+import FastString
\end{code}
\begin{code}
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
isForeignImport (L _ (ForeignImport _ _ _)) = True
-isForeignImport _ = False
+isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
isForeignExport (L _ (ForeignExport _ _ _)) = True
-isForeignExport _ = False
+isForeignExport _ = False
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Imports}
-%* *
+%* *
%************************************************************************
\begin{code}
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
- = addErrCtxt (foreignDeclCtxt fo) $
- tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
- let
- -- drop the foralls before inspecting the structure
- -- of the foreign type.
- (_, t_ty) = tcSplitForAllTys sig_ty
- (arg_tys, res_ty) = tcSplitFunTys t_ty
- id = mkLocalId nm sig_ty
- -- Use a LocalId to obey the invariant that locally-defined
- -- things are LocalIds. However, it does not need zonking,
- -- (so TcHsSyn.zonkForeignExports ignores it).
- in
- tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
- -- can't use sig_ty here because it :: Type and we need HsType Id
- -- hence the undefined
- returnM (id, ForeignImport (L loc id) undefined imp_decl')
+ = addErrCtxt (foreignDeclCtxt fo) $
+ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+ ; let
+ -- Drop the foralls before inspecting the
+ -- structure of the foreign type.
+ (_, t_ty) = tcSplitForAllTys sig_ty
+ (arg_tys, res_ty) = tcSplitFunTys t_ty
+ id = mkLocalId nm sig_ty
+ -- Use a LocalId to obey the invariant that locally-defined
+ -- things are LocalIds. However, it does not need zonking,
+ -- (so TcHsSyn.zonkForeignExports ignores it).
+
+ ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
+ -- Can't use sig_ty here because sig_ty :: Type and
+ -- we need HsType Id hence the undefined
+ ; return (id, ForeignImport (L loc id) undefined imp_decl') }
+tcFImport d = pprPanic "tcFImport" (ppr d)
\end{code}
------------ Checking types for foreign import ----------------------
\begin{code}
-tcCheckFIType _ arg_tys res_ty (DNImport spec)
- = checkCg checkDotnet `thenM_`
- getDOpts `thenM` \ dflags ->
- checkForeignArgs (isFFIDotnetTy dflags) arg_tys `thenM_`
- checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
- let (DNCallSpec isStatic kind _ _ _ _) = spec in
- (case kind of
- DNMethod | not isStatic ->
- case arg_tys of
- [] -> addErrTc illegalDNMethodSig
- _
- | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
- | otherwise -> returnM ()
- _ -> returnM ()) `thenM_`
- returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
-
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
- = checkCg checkCOrAsm `thenM_`
- check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
+tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
+
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
+ = ASSERT( null arg_tys )
+ do { checkCg checkCOrAsmOrLlvmOrInterp
+ ; checkSafety safety
+ ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
+ ; return idecl } -- NB check res_ty not sig_ty!
+ -- In case sig_ty is (forall a. ForeignPtr a)
+
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
+ -- Foreign wrapper (former f.e.d.)
+ -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
+ -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
+ -- as ft -> IO Addr is accepted, too. The use of the latter two forms
+ -- is DEPRECATED, though.
+ checkCg checkCOrAsmOrLlvmOrInterp
+ checkCConv cconv
+ checkSafety safety
+ case arg_tys of
+ [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
+ checkForeignRes nonIOok isFFIExportResultTy res1_ty
+ checkForeignRes mustBeIO isFFIDynResultTy res_ty
+ where
+ (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
+ _ -> addErrTc (illegalForeignTyErr empty sig_ty)
return idecl
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
- = -- Foreign wrapper (former f.e.d.)
- -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
- -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
- -- as ft -> IO Addr is accepted, too. The use of the latter two forms
- -- is DEPRECATED, though.
- checkCg checkCOrAsmOrInterp `thenM_`
- checkCConv cconv `thenM_`
- (case arg_tys of
- [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
- checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
- checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_`
- checkFEDArgs arg1_tys
- where
- (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
- other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_`
- return idecl
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
+ | isDynamicTarget target = do -- Foreign import dynamic
+ checkCg checkCOrAsmOrLlvmOrInterp
+ checkCConv cconv
+ checkSafety safety
+ case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
+ [] -> do
+ check False (illegalForeignTyErr empty sig_ty)
+ return idecl
+ (arg1_ty:arg_tys) -> do
+ dflags <- getDOpts
+ check (isFFIDynArgumentTy arg1_ty)
+ (illegalForeignTyErr argument arg1_ty)
+ checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
+ checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+ return idecl
+ | cconv == PrimCallConv = do
+ dflags <- getDOpts
+ check (xopt Opt_GHCForeignImportPrim dflags)
+ (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
+ checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
+ checkCTarget target
+ check (playSafe safety)
+ (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
+ checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
+ -- prim import result is more liberal, allows (#,,#)
+ checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty
+ return idecl
+ | otherwise = do -- Normal foreign import
+ checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
+ checkCConv cconv
+ checkSafety safety
+ checkCTarget target
+ dflags <- getDOpts
+ checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
+ checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+ checkMissingAmpersand dflags arg_tys res_ty
+ return idecl
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
- | isDynamicTarget target -- Foreign import dynamic
- = checkCg checkCOrAsmOrInterp `thenM_`
- checkCConv cconv `thenM_`
- case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
- [] ->
- check False (illegalForeignTyErr empty sig_ty) `thenM_`
- return idecl
- (arg1_ty:arg_tys) ->
- getDOpts `thenM` \ dflags ->
- check (isFFIDynArgumentTy arg1_ty)
- (illegalForeignTyErr argument arg1_ty) `thenM_`
- checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
- checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
- return idecl
- | otherwise -- Normal foreign import
- = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_`
- checkCConv cconv `thenM_`
- checkCTarget target `thenM_`
- getDOpts `thenM` \ dflags ->
- checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
- checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
- return idecl
-- This makes a convenient place to check
-- that the C identifier is valid for C
-checkCTarget (StaticTarget str)
- = checkCg checkCOrAsmOrDotNetOrInterp `thenM_`
+checkCTarget :: CCallTarget -> TcM ()
+checkCTarget (StaticTarget str _) = do
+ checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
check (isCLabelString str) (badCName str)
-\end{code}
-On an Alpha, with foreign export dynamic, due to a giant hack when
-building adjustor thunks, we only allow 4 integer arguments with
-foreign export dynamic (i.e., 32 bytes of arguments after padding each
-argument to a quadword, excluding floating-point arguments).
+checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
-The check is needed for both via-C and native-code routes
-\begin{code}
-#include "nativeGen/NCG.h"
-#if alpha_TARGET_ARCH
-checkFEDArgs arg_tys
- = check (integral_args <= 32) err
- where
- integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
- | prim_rep <- map typePrimRep arg_tys,
- primRepHint prim_rep /= FloatHint ]
- err = ptext SLIT("On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
-#else
-checkFEDArgs arg_tys = returnM ()
-#endif
+checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
+checkMissingAmpersand dflags arg_tys res_ty
+ | null arg_tys && isFunPtrTy res_ty &&
+ dopt Opt_WarnDodgyForeignImports dflags
+ = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
+ | otherwise
+ = return ()
\end{code}
-
%************************************************************************
-%* *
+%* *
\subsection{Exports}
-%* *
+%* *
%************************************************************************
\begin{code}
-tcForeignExports :: [LForeignDecl Name]
- -> TcM (LHsBinds TcId, [LForeignDecl TcId])
+tcForeignExports :: [LForeignDecl Name]
+ -> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports decls
= foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
where
- combine (binds, fs) fe =
- wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
- returnM (b `consBag` binds, f:fs)
+ combine (binds, fs) fe = do
+ (b, f) <- wrapLocSndM tcFExport fe
+ return (b `consBag` binds, f:fs)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
- addErrCtxt (foreignDeclCtxt fo) $
-
- tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
- tcPolyExpr (nlHsVar nm) sig_ty `thenM` \ rhs ->
-
- tcCheckFEType sig_ty spec `thenM_`
-
- -- we're exporting a function, but at a type possibly more
- -- constrained than its declared/inferred type. Hence the need
- -- to create a local binding which will call the exported function
- -- at a particular type (and, maybe, overloading).
-
- newUnique `thenM` \ uniq ->
- getModule `thenM` \ mod ->
- let
- gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) loc
- id = mkExportedLocalId gnm sig_ty
- bind = L loc (VarBind id rhs)
- in
- returnM (bind, ForeignExport (L loc id) undefined spec)
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
+ = addErrCtxt (foreignDeclCtxt fo) $ do
+
+ sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+ rhs <- tcPolyExpr (nlHsVar nm) sig_ty
+
+ tcCheckFEType sig_ty spec
+
+ -- we're exporting a function, but at a type possibly more
+ -- constrained than its declared/inferred type. Hence the need
+ -- to create a local binding which will call the exported function
+ -- at a particular type (and, maybe, overloading).
+
+
+ -- We need to give a name to the new top-level binding that
+ -- is *stable* (i.e. the compiler won't change it later),
+ -- because this name will be referred to by the C code stub.
+ id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
+ return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
+tcFExport d = pprPanic "tcFExport" (ppr d)
\end{code}
------------ Checking argument types for foreign export ----------------------
\begin{code}
-tcCheckFEType sig_ty (CExport (CExportStatic str _))
- = check (isCLabelString str) (badCName str) `thenM_`
- checkForeignArgs isFFIExternalTy arg_tys `thenM_`
+tcCheckFEType :: Type -> ForeignExport -> TcM ()
+tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
+ checkCg checkCOrAsmOrLlvm
+ check (isCLabelString str) (badCName str)
+ checkCConv cconv
+ checkForeignArgs isFFIExternalTy arg_tys
checkForeignRes nonIOok isFFIExportResultTy res_ty
where
-- Drop the foralls before inspecting n
%************************************************************************
-%* *
+%* *
\subsection{Miscellaneous}
-%* *
+%* *
%************************************************************************
\begin{code}
------------ Checking argument types for foreign import ----------------------
checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
checkForeignArgs pred tys
- = mappM go tys `thenM_`
- returnM ()
+ = mapM_ go tys
where
go ty = check (pred ty) (illegalForeignTyErr argument ty)
------------ Checking result types for foreign calls ----------------------
--- Check that the type has the form
+-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
+nonIOok, mustBeIO :: Bool
nonIOok = True
mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty
- -- (IO t) is ok, and so is any newtype wrapping thereof
- | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
+ -- (IO t) is ok, and so is any newtype wrapping thereof
+ | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
pred_res_ty res_ty
- = returnM ()
-
+ = return ()
+
| otherwise
- = check (non_io_result_ok && pred_res_ty ty)
- (illegalForeignTyErr result ty)
+ = check (non_io_result_ok && pred_res_ty ty)
+ (illegalForeignTyErr result ty)
\end{code}
\begin{code}
-#if defined(mingw32_TARGET_OS)
-checkDotnet HscC = Nothing
-checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
-#else
-checkDotnet other = Just (text "requires .NET support (-filx or win32)")
-#endif
-
-checkCOrAsm HscC = Nothing
-checkCOrAsm HscAsm = Nothing
-checkCOrAsm other
- = Just (text "requires via-C or native code generation (-fvia-C)")
-
-checkCOrAsmOrInterp HscC = Nothing
-checkCOrAsmOrInterp HscAsm = Nothing
-checkCOrAsmOrInterp HscInterpreted = Nothing
-checkCOrAsmOrInterp other
- = Just (text "requires interpreted, C or native code generation")
-
-checkCOrAsmOrDotNetOrInterp HscC = Nothing
-checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
-checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
-checkCOrAsmOrDotNetOrInterp other
- = Just (text "requires interpreted, C or native code generation")
-
-checkCg check
- = getDOpts `thenM` \ dflags ->
- let target = hscTarget dflags in
- case target of
- HscNothing -> returnM ()
- otherwise ->
- case check target of
- Nothing -> returnM ()
- Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
+checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc
+checkCOrAsmOrLlvm HscC = Nothing
+checkCOrAsmOrLlvm HscAsm = Nothing
+checkCOrAsmOrLlvm HscLlvm = Nothing
+checkCOrAsmOrLlvm _
+ = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
+
+checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
+checkCOrAsmOrLlvmOrInterp HscC = Nothing
+checkCOrAsmOrLlvmOrInterp HscAsm = Nothing
+checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing
+checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
+checkCOrAsmOrLlvmOrInterp _
+ = Just (text "requires interpreted, C, Llvm or native code generation")
+
+checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
+checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing
+checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing
+checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing
+checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
+checkCOrAsmOrLlvmOrDotNetOrInterp _
+ = Just (text "requires interpreted, C, Llvm or native code generation")
+
+checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
+checkCg check = do
+ dflags <- getDOpts
+ let target = hscTarget dflags
+ case target of
+ HscNothing -> return ()
+ _ ->
+ case check target of
+ Nothing -> return ()
+ Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code}
-
+
Calling conventions
\begin{code}
checkCConv :: CCallConv -> TcM ()
-checkCConv CCallConv = return ()
+checkCConv CCallConv = return ()
#if i386_TARGET_ARCH
-checkCConv StdCallConv = return ()
+checkCConv StdCallConv = return ()
#else
-checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
+-- This is a warning, not an error. see #3336
+checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
#endif
+checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
+checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
+\end{code}
+
+Deprecated "threadsafe" calls
+
+\begin{code}
+checkSafety :: Safety -> TcM ()
+checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.")
+checkSafety _ = return ()
\end{code}
Warnings
\begin{code}
check :: Bool -> Message -> TcM ()
-check True _ = returnM ()
+check True _ = return ()
check _ the_err = addErrTc the_err
+illegalForeignTyErr :: SDoc -> Type -> SDoc
illegalForeignTyErr arg_or_res ty
- = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
- ptext SLIT("type in foreign declaration:")])
- 4 (hsep [ppr ty])
+ = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
+ ptext (sLit "type in foreign declaration:")])
+ 2 (hsep [ppr ty])
-- Used for 'arg_or_res' argument to illegalForeignTyErr
+argument, result :: SDoc
argument = text "argument"
result = text "result"
badCName :: CLabelString -> Message
-badCName target
- = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
+badCName target
+ = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
+foreignDeclCtxt :: ForeignDecl Name -> SDoc
foreignDeclCtxt fo
- = hang (ptext SLIT("When checking declaration:"))
- 4 (ppr fo)
-
-illegalDNMethodSig
- = ptext SLIT("'This pointer' expected as last argument")
-
+ = hang (ptext (sLit "When checking declaration:"))
+ 2 (ppr fo)
\end{code}
-
projects / ghc-hetmet.git / blobdiff