2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1998
5 \section[TcForeign]{Typechecking \tr{foreign} declarations}
7 A foreign declaration is used to either give an externally
8 implemented function a Haskell type (and calling interface) or
9 give a Haskell function an external calling interface. Either way,
10 the range of argument and result types these functions can accommodate
11 is restricted to what the outside world understands (read C), and this
12 module checks to see if a foreign declaration has got a legal type.
21 #include "HsVersions.h"
44 isForeignImport :: LForeignDecl name -> Bool
45 isForeignImport (L _ (ForeignImport _ _ _)) = True
46 isForeignImport _ = False
49 isForeignExport :: LForeignDecl name -> Bool
50 isForeignExport (L _ (ForeignExport _ _ _)) = True
51 isForeignExport _ = False
54 %************************************************************************
58 %************************************************************************
61 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
62 tcForeignImports decls
63 = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
65 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
66 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
67 = addErrCtxt (foreignDeclCtxt fo) $
68 do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
70 -- Drop the foralls before inspecting the
71 -- structure of the foreign type.
72 (_, t_ty) = tcSplitForAllTys sig_ty
73 (arg_tys, res_ty) = tcSplitFunTys t_ty
74 id = mkLocalId nm sig_ty
75 -- Use a LocalId to obey the invariant that locally-defined
76 -- things are LocalIds. However, it does not need zonking,
77 -- (so TcHsSyn.zonkForeignExports ignores it).
79 ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
80 -- Can't use sig_ty here because sig_ty :: Type and
81 -- we need HsType Id hence the undefined
82 ; return (id, ForeignImport (L loc id) undefined imp_decl') }
83 tcFImport d = pprPanic "tcFImport" (ppr d)
87 ------------ Checking types for foreign import ----------------------
89 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
91 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
92 = ASSERT( null arg_tys )
93 do { checkCg checkCOrAsmOrLlvmOrInterp
95 ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
96 ; return idecl } -- NB check res_ty not sig_ty!
97 -- In case sig_ty is (forall a. ForeignPtr a)
99 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
100 -- Foreign wrapper (former f.e.d.)
101 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
102 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
103 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
104 -- is DEPRECATED, though.
105 checkCg checkCOrAsmOrLlvmOrInterp
109 [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
110 checkForeignRes nonIOok isFFIExportResultTy res1_ty
111 checkForeignRes mustBeIO isFFIDynResultTy res_ty
113 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
114 _ -> addErrTc (illegalForeignTyErr empty sig_ty)
117 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
118 | isDynamicTarget target = do -- Foreign import dynamic
119 checkCg checkCOrAsmOrLlvmOrInterp
122 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
124 check False (illegalForeignTyErr empty sig_ty)
126 (arg1_ty:arg_tys) -> do
128 check (isFFIDynArgumentTy arg1_ty)
129 (illegalForeignTyErr argument arg1_ty)
130 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
131 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
133 | cconv == PrimCallConv = do
135 check (xopt Opt_GHCForeignImportPrim dflags)
136 (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
137 checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
139 check (playSafe safety)
140 (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
141 checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
142 -- prim import result is more liberal, allows (#,,#)
143 checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty
145 | otherwise = do -- Normal foreign import
146 checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
151 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
152 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
153 checkMissingAmpersand dflags arg_tys res_ty
157 -- This makes a convenient place to check
158 -- that the C identifier is valid for C
159 checkCTarget :: CCallTarget -> TcM ()
160 checkCTarget (StaticTarget str _) = do
161 checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
162 check (isCLabelString str) (badCName str)
164 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
167 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
168 checkMissingAmpersand dflags arg_tys res_ty
169 | null arg_tys && isFunPtrTy res_ty &&
170 dopt Opt_WarnDodgyForeignImports dflags
171 = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
176 %************************************************************************
180 %************************************************************************
183 tcForeignExports :: [LForeignDecl Name]
184 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
185 tcForeignExports decls
186 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
188 combine (binds, fs) fe = do
189 (b, f) <- wrapLocSndM tcFExport fe
190 return (b `consBag` binds, f:fs)
192 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
193 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
194 addErrCtxt (foreignDeclCtxt fo) $ do
196 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
197 rhs <- tcPolyExpr (nlHsVar nm) sig_ty
199 tcCheckFEType sig_ty spec
201 -- we're exporting a function, but at a type possibly more
202 -- constrained than its declared/inferred type. Hence the need
203 -- to create a local binding which will call the exported function
204 -- at a particular type (and, maybe, overloading).
207 -- We need to give a name to the new top-level binding that
208 -- is *stable* (i.e. the compiler won't change it later),
209 -- because this name will be referred to by the C code stub.
210 id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
211 return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
212 tcFExport d = pprPanic "tcFExport" (ppr d)
215 ------------ Checking argument types for foreign export ----------------------
218 tcCheckFEType :: Type -> ForeignExport -> TcM ()
219 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
220 checkCg checkCOrAsmOrLlvm
221 check (isCLabelString str) (badCName str)
223 checkForeignArgs isFFIExternalTy arg_tys
224 checkForeignRes nonIOok isFFIExportResultTy res_ty
226 -- Drop the foralls before inspecting n
227 -- the structure of the foreign type.
228 (_, t_ty) = tcSplitForAllTys sig_ty
229 (arg_tys, res_ty) = tcSplitFunTys t_ty
234 %************************************************************************
236 \subsection{Miscellaneous}
238 %************************************************************************
241 ------------ Checking argument types for foreign import ----------------------
242 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
243 checkForeignArgs pred tys
246 go ty = check (pred ty) (illegalForeignTyErr argument ty)
248 ------------ Checking result types for foreign calls ----------------------
249 -- Check that the type has the form
250 -- (IO t) or (t) , and that t satisfies the given predicate.
252 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
254 nonIOok, mustBeIO :: Bool
258 checkForeignRes non_io_result_ok pred_res_ty ty
259 -- (IO t) is ok, and so is any newtype wrapping thereof
260 | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
265 = check (non_io_result_ok && pred_res_ty ty)
266 (illegalForeignTyErr result ty)
270 checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc
271 checkCOrAsmOrLlvm HscC = Nothing
272 checkCOrAsmOrLlvm HscAsm = Nothing
273 checkCOrAsmOrLlvm HscLlvm = Nothing
275 = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
277 checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
278 checkCOrAsmOrLlvmOrInterp HscC = Nothing
279 checkCOrAsmOrLlvmOrInterp HscAsm = Nothing
280 checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing
281 checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
282 checkCOrAsmOrLlvmOrInterp _
283 = Just (text "requires interpreted, C, Llvm or native code generation")
285 checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
286 checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing
287 checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing
288 checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing
289 checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
290 checkCOrAsmOrLlvmOrDotNetOrInterp _
291 = Just (text "requires interpreted, C, Llvm or native code generation")
293 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
296 let target = hscTarget dflags
298 HscNothing -> return ()
302 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
308 checkCConv :: CCallConv -> TcM ()
309 checkCConv CCallConv = return ()
311 checkCConv StdCallConv = return ()
313 -- This is a warning, not an error. see #3336
314 checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform,"$$ text "treating as ccall")
316 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
317 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
320 Deprecated "threadsafe" calls
323 checkSafety :: Safety -> TcM ()
324 checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.")
325 checkSafety _ = return ()
331 check :: Bool -> Message -> TcM ()
332 check True _ = return ()
333 check _ the_err = addErrTc the_err
335 illegalForeignTyErr :: SDoc -> Type -> SDoc
336 illegalForeignTyErr arg_or_res ty
337 = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
338 ptext (sLit "type in foreign declaration:")])
341 -- Used for 'arg_or_res' argument to illegalForeignTyErr
342 argument, result :: SDoc
343 argument = text "argument"
344 result = text "result"
346 badCName :: CLabelString -> Message
348 = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
350 foreignDeclCtxt :: ForeignDecl Name -> SDoc
352 = hang (ptext (sLit "When checking declaration:"))