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
155 checkCg (checkCOrAsmOrDotNetOrInterp)
157 check (playSafe safety)
158 (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
160 checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
161 -- prim import result is more liberal, allows (#,,#)
162 checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty
164 | otherwise = do -- Normal foreign import
165 checkCg (checkCOrAsmOrDotNetOrInterp)
170 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
171 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
172 checkMissingAmpersand dflags arg_tys res_ty
175 -- This makes a convenient place to check
176 -- that the C identifier is valid for C
177 checkCTarget :: CCallTarget -> TcM ()
178 checkCTarget (StaticTarget str) = do
179 checkCg checkCOrAsmOrDotNetOrInterp
180 check (isCLabelString str) (badCName str)
181 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
183 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
184 checkMissingAmpersand dflags arg_tys res_ty
185 | null arg_tys && isFunPtrTy res_ty &&
186 dopt Opt_WarnDodgyForeignImports dflags
187 = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
192 On an Alpha, with foreign export dynamic, due to a giant hack when
193 building adjustor thunks, we only allow 4 integer arguments with
194 foreign export dynamic (i.e., 32 bytes of arguments after padding each
195 argument to a quadword, excluding floating-point arguments).
197 The check is needed for both via-C and native-code routes
200 #include "nativeGen/NCG.h"
202 checkFEDArgs :: [Type] -> TcM ()
203 #if alpha_TARGET_ARCH
205 = check (integral_args <= 32) err
207 integral_args = sum [ (widthInBytes . argMachRep . primRepToCgRep) prim_rep
208 | prim_rep <- map typePrimRep arg_tys,
209 primRepHint prim_rep /= FloatHint ]
210 err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
212 checkFEDArgs _ = return ()
217 %************************************************************************
221 %************************************************************************
224 tcForeignExports :: [LForeignDecl Name]
225 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
226 tcForeignExports decls
227 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
229 combine (binds, fs) fe = do
230 (b, f) <- wrapLocSndM tcFExport fe
231 return (b `consBag` binds, f:fs)
233 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
234 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
235 addErrCtxt (foreignDeclCtxt fo) $ do
237 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
238 rhs <- tcPolyExpr (nlHsVar nm) sig_ty
240 tcCheckFEType sig_ty spec
242 -- we're exporting a function, but at a type possibly more
243 -- constrained than its declared/inferred type. Hence the need
244 -- to create a local binding which will call the exported function
245 -- at a particular type (and, maybe, overloading).
248 -- We need to give a name to the new top-level binding that
249 -- is *stable* (i.e. the compiler won't change it later),
250 -- because this name will be referred to by the C code stub.
251 id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
252 return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
253 tcFExport d = pprPanic "tcFExport" (ppr d)
256 ------------ Checking argument types for foreign export ----------------------
259 tcCheckFEType :: Type -> ForeignExport -> TcM ()
260 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
261 check (isCLabelString str) (badCName str)
263 checkForeignArgs isFFIExternalTy arg_tys
264 checkForeignRes nonIOok isFFIExportResultTy res_ty
266 -- Drop the foralls before inspecting n
267 -- the structure of the foreign type.
268 (_, t_ty) = tcSplitForAllTys sig_ty
269 (arg_tys, res_ty) = tcSplitFunTys t_ty
270 tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
275 %************************************************************************
277 \subsection{Miscellaneous}
279 %************************************************************************
282 ------------ Checking argument types for foreign import ----------------------
283 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
284 checkForeignArgs pred tys
287 go ty = check (pred ty) (illegalForeignTyErr argument ty)
289 ------------ Checking result types for foreign calls ----------------------
290 -- Check that the type has the form
291 -- (IO t) or (t) , and that t satisfies the given predicate.
293 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
295 nonIOok, mustBeIO :: Bool
299 checkForeignRes non_io_result_ok pred_res_ty ty
300 -- (IO t) is ok, and so is any newtype wrapping thereof
301 | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
306 = check (non_io_result_ok && pred_res_ty ty)
307 (illegalForeignTyErr result ty)
311 checkDotnet :: HscTarget -> Maybe SDoc
312 #if defined(mingw32_TARGET_OS)
313 checkDotnet HscC = Nothing
314 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
316 checkDotnet _ = Just (text "requires .NET support (-filx or win32)")
319 checkCOrAsm :: HscTarget -> Maybe SDoc
320 checkCOrAsm HscC = Nothing
321 checkCOrAsm HscAsm = Nothing
323 = Just (text "requires via-C or native code generation (-fvia-C)")
325 checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
326 checkCOrAsmOrInterp HscC = Nothing
327 checkCOrAsmOrInterp HscAsm = Nothing
328 checkCOrAsmOrInterp HscInterpreted = Nothing
329 checkCOrAsmOrInterp _
330 = Just (text "requires interpreted, C or native code generation")
332 checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
333 checkCOrAsmOrDotNetOrInterp HscC = Nothing
334 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
335 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
336 checkCOrAsmOrDotNetOrInterp _
337 = Just (text "requires interpreted, C or native code generation")
339 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
342 let target = hscTarget dflags
344 HscNothing -> return ()
348 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
354 checkCConv :: CCallConv -> TcM ()
355 checkCConv CCallConv = return ()
357 checkCConv StdCallConv = return ()
359 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall")
361 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
362 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
365 Deprecated "threadsafe" calls
368 checkSafety :: Safety -> TcM ()
369 checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.")
370 checkSafety _ = return ()
376 check :: Bool -> Message -> TcM ()
377 check True _ = return ()
378 check _ the_err = addErrTc the_err
380 illegalForeignTyErr :: SDoc -> Type -> SDoc
381 illegalForeignTyErr arg_or_res ty
382 = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
383 ptext (sLit "type in foreign declaration:")])
386 -- Used for 'arg_or_res' argument to illegalForeignTyErr
387 argument, result :: SDoc
388 argument = text "argument"
389 result = text "result"
391 badCName :: CLabelString -> Message
393 = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
395 foreignDeclCtxt :: ForeignDecl Name -> SDoc
397 = hang (ptext (sLit "When checking declaration:"))
400 illegalDNMethodSig :: SDoc
402 = ptext (sLit "'This pointer' expected as last argument")