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"
49 isForeignImport :: LForeignDecl name -> Bool
50 isForeignImport (L _ (ForeignImport _ _ _)) = True
51 isForeignImport _ = False
54 isForeignExport :: LForeignDecl name -> Bool
55 isForeignExport (L _ (ForeignExport _ _ _)) = True
56 isForeignExport _ = False
59 %************************************************************************
63 %************************************************************************
66 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
67 tcForeignImports decls
68 = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
70 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
71 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
72 = addErrCtxt (foreignDeclCtxt fo) $
73 do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
75 -- Drop the foralls before inspecting the
76 -- structure of the foreign type.
77 (_, t_ty) = tcSplitForAllTys sig_ty
78 (arg_tys, res_ty) = tcSplitFunTys t_ty
79 id = mkLocalId nm sig_ty
80 -- Use a LocalId to obey the invariant that locally-defined
81 -- things are LocalIds. However, it does not need zonking,
82 -- (so TcHsSyn.zonkForeignExports ignores it).
84 ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
85 -- Can't use sig_ty here because sig_ty :: Type and
86 -- we need HsType Id hence the undefined
87 ; return (id, ForeignImport (L loc id) undefined imp_decl') }
88 tcFImport d = pprPanic "tcFImport" (ppr d)
92 ------------ Checking types for foreign import ----------------------
94 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
95 tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
98 checkForeignArgs (isFFIDotnetTy dflags) arg_tys
99 checkForeignRes nonIOok (isFFIDotnetTy dflags) res_ty
100 let (DNCallSpec isStatic kind _ _ _ _) = spec
102 DNMethod | not isStatic ->
104 [] -> addErrTc illegalDNMethodSig
106 | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
107 | otherwise -> return ()
109 return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
111 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _))
112 = ASSERT( null arg_tys )
113 do { checkCg checkCOrAsm
115 ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
116 ; return idecl } -- NB check res_ty not sig_ty!
117 -- In case sig_ty is (forall a. ForeignPtr a)
119 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) = do
120 -- Foreign wrapper (former f.e.d.)
121 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
122 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
123 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
124 -- is DEPRECATED, though.
125 checkCg checkCOrAsmOrInterp
129 [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
130 checkForeignRes nonIOok isFFIExportResultTy res1_ty
131 checkForeignRes mustBeIO isFFIDynResultTy res_ty
132 checkFEDArgs arg1_tys
134 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
135 _ -> addErrTc (illegalForeignTyErr empty sig_ty)
138 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
139 | isDynamicTarget target = do -- Foreign import dynamic
140 checkCg checkCOrAsmOrInterp
143 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
145 check False (illegalForeignTyErr empty sig_ty)
147 (arg1_ty:arg_tys) -> do
149 check (isFFIDynArgumentTy arg1_ty)
150 (illegalForeignTyErr argument arg1_ty)
151 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
152 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
154 | cconv == PrimCallConv = do
156 check (dopt Opt_GHCForeignImportPrim dflags)
157 (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
158 checkCg (checkCOrAsmOrDotNetOrInterp)
160 check (playSafe safety)
161 (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
162 checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
163 -- prim import result is more liberal, allows (#,,#)
164 checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty
166 | otherwise = do -- Normal foreign import
167 checkCg (checkCOrAsmOrDotNetOrInterp)
172 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
173 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
174 checkMissingAmpersand dflags arg_tys res_ty
177 -- This makes a convenient place to check
178 -- that the C identifier is valid for C
179 checkCTarget :: CCallTarget -> TcM ()
180 checkCTarget (StaticTarget str) = do
181 checkCg checkCOrAsmOrDotNetOrInterp
182 check (isCLabelString str) (badCName str)
183 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
185 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
186 checkMissingAmpersand dflags arg_tys res_ty
187 | null arg_tys && isFunPtrTy res_ty &&
188 dopt Opt_WarnDodgyForeignImports dflags
189 = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
194 On an Alpha, with foreign export dynamic, due to a giant hack when
195 building adjustor thunks, we only allow 4 integer arguments with
196 foreign export dynamic (i.e., 32 bytes of arguments after padding each
197 argument to a quadword, excluding floating-point arguments).
199 The check is needed for both via-C and native-code routes
202 #include "nativeGen/NCG.h"
204 checkFEDArgs :: [Type] -> TcM ()
205 #if alpha_TARGET_ARCH
207 = check (integral_args <= 32) err
209 integral_args = sum [ (widthInBytes . argMachRep . primRepToCgRep) prim_rep
210 | prim_rep <- map typePrimRep arg_tys,
211 primRepHint prim_rep /= FloatHint ]
212 err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
214 checkFEDArgs _ = return ()
219 %************************************************************************
223 %************************************************************************
226 tcForeignExports :: [LForeignDecl Name]
227 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
228 tcForeignExports decls
229 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
231 combine (binds, fs) fe = do
232 (b, f) <- wrapLocSndM tcFExport fe
233 return (b `consBag` binds, f:fs)
235 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
236 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
237 addErrCtxt (foreignDeclCtxt fo) $ do
239 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
240 rhs <- tcPolyExpr (nlHsVar nm) sig_ty
242 tcCheckFEType sig_ty spec
244 -- we're exporting a function, but at a type possibly more
245 -- constrained than its declared/inferred type. Hence the need
246 -- to create a local binding which will call the exported function
247 -- at a particular type (and, maybe, overloading).
250 -- We need to give a name to the new top-level binding that
251 -- is *stable* (i.e. the compiler won't change it later),
252 -- because this name will be referred to by the C code stub.
253 id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
254 return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
255 tcFExport d = pprPanic "tcFExport" (ppr d)
258 ------------ Checking argument types for foreign export ----------------------
261 tcCheckFEType :: Type -> ForeignExport -> TcM ()
262 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
263 check (isCLabelString str) (badCName str)
265 checkForeignArgs isFFIExternalTy arg_tys
266 checkForeignRes nonIOok isFFIExportResultTy res_ty
268 -- Drop the foralls before inspecting n
269 -- the structure of the foreign type.
270 (_, t_ty) = tcSplitForAllTys sig_ty
271 (arg_tys, res_ty) = tcSplitFunTys t_ty
272 tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
277 %************************************************************************
279 \subsection{Miscellaneous}
281 %************************************************************************
284 ------------ Checking argument types for foreign import ----------------------
285 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
286 checkForeignArgs pred tys
289 go ty = check (pred ty) (illegalForeignTyErr argument ty)
291 ------------ Checking result types for foreign calls ----------------------
292 -- Check that the type has the form
293 -- (IO t) or (t) , and that t satisfies the given predicate.
295 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
297 nonIOok, mustBeIO :: Bool
301 checkForeignRes non_io_result_ok pred_res_ty ty
302 -- (IO t) is ok, and so is any newtype wrapping thereof
303 | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
308 = check (non_io_result_ok && pred_res_ty ty)
309 (illegalForeignTyErr result ty)
313 checkDotnet :: HscTarget -> Maybe SDoc
314 #if defined(mingw32_TARGET_OS)
315 checkDotnet HscC = Nothing
316 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
318 checkDotnet _ = Just (text "requires .NET support (-filx or win32)")
321 checkCOrAsm :: HscTarget -> Maybe SDoc
322 checkCOrAsm HscC = Nothing
323 checkCOrAsm HscAsm = Nothing
325 = Just (text "requires via-C or native code generation (-fvia-C)")
327 checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
328 checkCOrAsmOrInterp HscC = Nothing
329 checkCOrAsmOrInterp HscAsm = Nothing
330 checkCOrAsmOrInterp HscInterpreted = Nothing
331 checkCOrAsmOrInterp _
332 = Just (text "requires interpreted, C or native code generation")
334 checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
335 checkCOrAsmOrDotNetOrInterp HscC = Nothing
336 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
337 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
338 checkCOrAsmOrDotNetOrInterp _
339 = Just (text "requires interpreted, C or native code generation")
341 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
344 let target = hscTarget dflags
346 HscNothing -> return ()
350 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
356 checkCConv :: CCallConv -> TcM ()
357 checkCConv CCallConv = return ()
359 checkCConv StdCallConv = return ()
361 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall")
363 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
364 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
367 Deprecated "threadsafe" calls
370 checkSafety :: Safety -> TcM ()
371 checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.")
372 checkSafety _ = return ()
378 check :: Bool -> Message -> TcM ()
379 check True _ = return ()
380 check _ the_err = addErrTc the_err
382 illegalForeignTyErr :: SDoc -> Type -> SDoc
383 illegalForeignTyErr arg_or_res ty
384 = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
385 ptext (sLit "type in foreign declaration:")])
388 -- Used for 'arg_or_res' argument to illegalForeignTyErr
389 argument, result :: SDoc
390 argument = text "argument"
391 result = text "result"
393 badCName :: CLabelString -> Message
395 = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
397 foreignDeclCtxt :: ForeignDecl Name -> SDoc
399 = hang (ptext (sLit "When checking declaration:"))
402 illegalDNMethodSig :: SDoc
404 = ptext (sLit "'This pointer' expected as last argument")