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"
48 isForeignImport :: LForeignDecl name -> Bool
49 isForeignImport (L _ (ForeignImport _ _ _)) = True
50 isForeignImport _ = False
53 isForeignExport :: LForeignDecl name -> Bool
54 isForeignExport (L _ (ForeignExport _ _ _)) = True
55 isForeignExport _ = False
58 %************************************************************************
62 %************************************************************************
65 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
66 tcForeignImports decls
67 = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
69 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
70 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
71 = addErrCtxt (foreignDeclCtxt fo) $
72 do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
74 -- Drop the foralls before inspecting the
75 -- structure of the foreign type.
76 (_, t_ty) = tcSplitForAllTys sig_ty
77 (arg_tys, res_ty) = tcSplitFunTys t_ty
78 id = mkLocalId nm sig_ty
79 -- Use a LocalId to obey the invariant that locally-defined
80 -- things are LocalIds. However, it does not need zonking,
81 -- (so TcHsSyn.zonkForeignExports ignores it).
83 ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
84 -- Can't use sig_ty here because sig_ty :: Type and
85 -- we need HsType Id hence the undefined
86 ; return (id, ForeignImport (L loc id) undefined imp_decl') }
87 tcFImport d = pprPanic "tcFImport" (ppr d)
91 ------------ Checking types for foreign import ----------------------
93 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
94 tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
97 checkForeignArgs (isFFIDotnetTy dflags) arg_tys
98 checkForeignRes nonIOok (isFFIDotnetTy dflags) res_ty
99 let (DNCallSpec isStatic kind _ _ _ _) = spec
101 DNMethod | not isStatic ->
103 [] -> addErrTc illegalDNMethodSig
105 | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
106 | otherwise -> return ()
108 return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
110 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
111 = ASSERT( null arg_tys )
112 do { checkCg checkCOrAsm
114 ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
115 ; return idecl } -- NB check res_ty not sig_ty!
116 -- In case sig_ty is (forall a. ForeignPtr a)
118 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
119 -- Foreign wrapper (former f.e.d.)
120 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
121 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
122 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
123 -- is DEPRECATED, though.
124 checkCg checkCOrAsmOrInterp
128 [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
129 checkForeignRes nonIOok isFFIExportResultTy res1_ty
130 checkForeignRes mustBeIO isFFIDynResultTy res_ty
131 checkFEDArgs arg1_tys
133 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
134 _ -> addErrTc (illegalForeignTyErr empty sig_ty)
137 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
138 | isDynamicTarget target = do -- Foreign import dynamic
139 checkCg checkCOrAsmOrInterp
142 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
144 check False (illegalForeignTyErr empty sig_ty)
146 (arg1_ty:arg_tys) -> do
148 check (isFFIDynArgumentTy arg1_ty)
149 (illegalForeignTyErr argument arg1_ty)
150 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
151 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
153 | cconv == PrimCallConv = do
155 check (dopt Opt_GHCForeignImportPrim dflags)
156 (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
157 checkCg (checkCOrAsmOrDotNetOrInterp)
159 check (playSafe safety)
160 (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
161 checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
162 -- prim import result is more liberal, allows (#,,#)
163 checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty
165 | otherwise = do -- Normal foreign import
166 checkCg (checkCOrAsmOrDotNetOrInterp)
171 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
172 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
173 checkMissingAmpersand dflags arg_tys res_ty
176 -- This makes a convenient place to check
177 -- that the C identifier is valid for C
178 checkCTarget :: CCallTarget -> TcM ()
179 checkCTarget (StaticTarget str) = do
180 checkCg checkCOrAsmOrDotNetOrInterp
181 check (isCLabelString str) (badCName str)
182 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
184 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
185 checkMissingAmpersand dflags arg_tys res_ty
186 | null arg_tys && isFunPtrTy res_ty &&
187 dopt Opt_WarnDodgyForeignImports dflags
188 = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
193 On an Alpha, with foreign export dynamic, due to a giant hack when
194 building adjustor thunks, we only allow 4 integer arguments with
195 foreign export dynamic (i.e., 32 bytes of arguments after padding each
196 argument to a quadword, excluding floating-point arguments).
198 The check is needed for both via-C and native-code routes
201 #include "nativeGen/NCG.h"
203 checkFEDArgs :: [Type] -> TcM ()
204 #if alpha_TARGET_ARCH
206 = check (integral_args <= 32) err
208 integral_args = sum [ (widthInBytes . argMachRep . primRepToCgRep) prim_rep
209 | prim_rep <- map typePrimRep arg_tys,
210 primRepHint prim_rep /= FloatHint ]
211 err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
213 checkFEDArgs _ = return ()
218 %************************************************************************
222 %************************************************************************
225 tcForeignExports :: [LForeignDecl Name]
226 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
227 tcForeignExports decls
228 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
230 combine (binds, fs) fe = do
231 (b, f) <- wrapLocSndM tcFExport fe
232 return (b `consBag` binds, f:fs)
234 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
235 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
236 addErrCtxt (foreignDeclCtxt fo) $ do
238 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
239 rhs <- tcPolyExpr (nlHsVar nm) sig_ty
241 tcCheckFEType sig_ty spec
243 -- we're exporting a function, but at a type possibly more
244 -- constrained than its declared/inferred type. Hence the need
245 -- to create a local binding which will call the exported function
246 -- at a particular type (and, maybe, overloading).
249 -- We need to give a name to the new top-level binding that
250 -- is *stable* (i.e. the compiler won't change it later),
251 -- because this name will be referred to by the C code stub.
252 id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
253 return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
254 tcFExport d = pprPanic "tcFExport" (ppr d)
257 ------------ Checking argument types for foreign export ----------------------
260 tcCheckFEType :: Type -> ForeignExport -> TcM ()
261 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
262 check (isCLabelString str) (badCName str)
264 checkForeignArgs isFFIExternalTy arg_tys
265 checkForeignRes nonIOok isFFIExportResultTy res_ty
267 -- Drop the foralls before inspecting n
268 -- the structure of the foreign type.
269 (_, t_ty) = tcSplitForAllTys sig_ty
270 (arg_tys, res_ty) = tcSplitFunTys t_ty
271 tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
276 %************************************************************************
278 \subsection{Miscellaneous}
280 %************************************************************************
283 ------------ Checking argument types for foreign import ----------------------
284 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
285 checkForeignArgs pred tys
288 go ty = check (pred ty) (illegalForeignTyErr argument ty)
290 ------------ Checking result types for foreign calls ----------------------
291 -- Check that the type has the form
292 -- (IO t) or (t) , and that t satisfies the given predicate.
294 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
296 nonIOok, mustBeIO :: Bool
300 checkForeignRes non_io_result_ok pred_res_ty ty
301 -- (IO t) is ok, and so is any newtype wrapping thereof
302 | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
307 = check (non_io_result_ok && pred_res_ty ty)
308 (illegalForeignTyErr result ty)
312 checkDotnet :: HscTarget -> Maybe SDoc
313 #if defined(mingw32_TARGET_OS)
314 checkDotnet HscC = Nothing
315 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
317 checkDotnet _ = Just (text "requires .NET support (-filx or win32)")
320 checkCOrAsm :: HscTarget -> Maybe SDoc
321 checkCOrAsm HscC = Nothing
322 checkCOrAsm HscAsm = Nothing
324 = Just (text "requires via-C or native code generation (-fvia-C)")
326 checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
327 checkCOrAsmOrInterp HscC = Nothing
328 checkCOrAsmOrInterp HscAsm = Nothing
329 checkCOrAsmOrInterp HscInterpreted = Nothing
330 checkCOrAsmOrInterp _
331 = Just (text "requires interpreted, C or native code generation")
333 checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
334 checkCOrAsmOrDotNetOrInterp HscC = Nothing
335 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
336 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
337 checkCOrAsmOrDotNetOrInterp _
338 = Just (text "requires interpreted, C or native code generation")
340 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
343 let target = hscTarget dflags
345 HscNothing -> return ()
349 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
355 checkCConv :: CCallConv -> TcM ()
356 checkCConv CCallConv = return ()
358 checkCConv StdCallConv = return ()
360 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall")
362 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
363 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
366 Deprecated "threadsafe" calls
369 checkSafety :: Safety -> TcM ()
370 checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.")
371 checkSafety _ = return ()
377 check :: Bool -> Message -> TcM ()
378 check True _ = return ()
379 check _ the_err = addErrTc the_err
381 illegalForeignTyErr :: SDoc -> Type -> SDoc
382 illegalForeignTyErr arg_or_res ty
383 = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
384 ptext (sLit "type in foreign declaration:")])
387 -- Used for 'arg_or_res' argument to illegalForeignTyErr
388 argument, result :: SDoc
389 argument = text "argument"
390 result = text "result"
392 badCName :: CLabelString -> Message
394 = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
396 foreignDeclCtxt :: ForeignDecl Name -> SDoc
398 = hang (ptext (sLit "When checking declaration:"))
401 illegalDNMethodSig :: SDoc
403 = ptext (sLit "'This pointer' expected as last argument")