module checks to see if a foreign declaration has got a legal type.
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcForeign
(
tcForeignImports
import TcRnMonad
import TcHsType
import TcExpr
+import TcEnv
import ForeignCall
import ErrUtils
#if alpha_TARGET_ARCH
import Type
import SMRep
-import MachOp
#endif
import Name
import OccName
import Outputable
import SrcLoc
import Bag
-import Unique
import FastString
\end{code}
-- can't use sig_ty here because it :: 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 :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
checkCg checkDotnet
dflags <- getDOpts
_ -> return ()
return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = do
+tcCheckFIType sig_ty _ _ idecl@(CImport _ _ _ _ (CLabel _)) = do
checkCg checkCOrAsm
check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
return idecl
checkFEDArgs arg1_tys
where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
- other -> addErrTc (illegalForeignTyErr empty sig_ty)
+ _ -> addErrTc (illegalForeignTyErr empty sig_ty)
return idecl
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
dflags <- getDOpts
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+ checkMissingAmpersand dflags arg_tys res_ty
return idecl
-- This makes a convenient place to check
-- that the C identifier is valid for C
+checkCTarget :: CCallTarget -> TcM ()
checkCTarget (StaticTarget str) = do
checkCg checkCOrAsmOrDotNetOrInterp
check (isCLabelString str) (badCName str)
+checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
+
+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}
On an Alpha, with foreign export dynamic, due to a giant hack when
\begin{code}
#include "nativeGen/NCG.h"
+
+checkFEDArgs :: [Type] -> TcM ()
#if alpha_TARGET_ARCH
checkFEDArgs arg_tys
= check (integral_args <= 32) err
where
- integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
+ integral_args = sum [ (widthInBytes . 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")
+ err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
#else
-checkFEDArgs arg_tys = return ()
+checkFEDArgs _ = return ()
#endif
\end{code}
-- to create a local binding which will call the exported function
-- at a particular type (and, maybe, overloading).
- uniq <- newUnique
- mod <- getModule
- let
- -- 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.
- -- Furthermore, the name must be unique (see #1533). If the
- -- same function is foreign-exported multiple times, the
- -- top-level bindings generated must not have the same name.
- -- Hence we create an External name (doesn't change), and we
- -- append a Unique to the string right here.
- uniq_str = showSDoc (pprUnique uniq)
- occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
- gnm = mkExternalName uniq mod (mkForeignExportOcc occ) loc
- id = mkExportedLocalId gnm sig_ty
- bind = L loc (VarBind id rhs)
-
- return (bind, ForeignExport (L loc id) undefined spec)
+
+ -- 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 (L loc (VarBind 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 :: Type -> ForeignExport -> TcM ()
tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
check (isCLabelString str) (badCName str)
checkForeignArgs isFFIExternalTy arg_tys
-- the structure of the foreign type.
(_, t_ty) = tcSplitForAllTys sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
+tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
\end{code}
--
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,
+ | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
pred_res_ty res_ty
= return ()
\end{code}
\begin{code}
+checkDotnet :: HscTarget -> Maybe SDoc
#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)")
+checkDotnet _ = Just (text "requires .NET support (-filx or win32)")
#endif
+checkCOrAsm :: HscTarget -> Maybe SDoc
checkCOrAsm HscC = Nothing
checkCOrAsm HscAsm = Nothing
-checkCOrAsm other
+checkCOrAsm _
= Just (text "requires via-C or native code generation (-fvia-C)")
+checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrInterp HscC = Nothing
checkCOrAsmOrInterp HscAsm = Nothing
checkCOrAsmOrInterp HscInterpreted = Nothing
-checkCOrAsmOrInterp other
+checkCOrAsmOrInterp _
= Just (text "requires interpreted, C or native code generation")
+checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrDotNetOrInterp HscC = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
-checkCOrAsmOrDotNetOrInterp other
+checkCOrAsmOrDotNetOrInterp _
= Just (text "requires interpreted, C or native code generation")
+checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
checkCg check = do
dflags <- getDOpts
let target = hscTarget dflags
case target of
HscNothing -> return ()
- otherwise ->
+ _ ->
case check target of
Nothing -> return ()
Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
#else
checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
#endif
+checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
\end{code}
Warnings
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:")])
+ = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
+ ptext (sLit "type in foreign declaration:")])
4 (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")]
+ = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
+foreignDeclCtxt :: ForeignDecl Name -> SDoc
foreignDeclCtxt fo
- = hang (ptext SLIT("When checking declaration:"))
+ = hang (ptext (sLit "When checking declaration:"))
4 (ppr fo)
-illegalDNMethodSig
- = ptext SLIT("'This pointer' expected as last argument")
+illegalDNMethodSig :: SDoc
+illegalDNMethodSig
+ = ptext (sLit "'This pointer' expected as last argument")
\end{code}
projects / ghc-hetmet.git / blobdiff