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 _ _ _ _ (CLabel _))
112 = ASSERT( null arg_tys )
113 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 _ _ _ 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
127 [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
128 checkForeignRes nonIOok isFFIExportResultTy res1_ty
129 checkForeignRes mustBeIO isFFIDynResultTy res_ty
130 checkFEDArgs arg1_tys
132 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
133 _ -> addErrTc (illegalForeignTyErr empty sig_ty)
136 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
137 | isDynamicTarget target = do -- Foreign import dynamic
138 checkCg checkCOrAsmOrInterp
140 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
142 check False (illegalForeignTyErr empty sig_ty)
144 (arg1_ty:arg_tys) -> do
146 check (isFFIDynArgumentTy arg1_ty)
147 (illegalForeignTyErr argument arg1_ty)
148 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
149 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
151 | otherwise = do -- Normal foreign import
152 checkCg (checkCOrAsmOrDotNetOrInterp)
156 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
157 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
158 checkMissingAmpersand dflags arg_tys res_ty
161 -- This makes a convenient place to check
162 -- that the C identifier is valid for C
163 checkCTarget :: CCallTarget -> TcM ()
164 checkCTarget (StaticTarget str) = do
165 checkCg checkCOrAsmOrDotNetOrInterp
166 check (isCLabelString str) (badCName str)
167 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
169 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
170 checkMissingAmpersand dflags arg_tys res_ty
171 | null arg_tys && isFunPtrTy res_ty &&
172 dopt Opt_WarnDodgyForeignImports dflags
173 = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
178 On an Alpha, with foreign export dynamic, due to a giant hack when
179 building adjustor thunks, we only allow 4 integer arguments with
180 foreign export dynamic (i.e., 32 bytes of arguments after padding each
181 argument to a quadword, excluding floating-point arguments).
183 The check is needed for both via-C and native-code routes
186 #include "nativeGen/NCG.h"
188 checkFEDArgs :: [Type] -> TcM ()
189 #if alpha_TARGET_ARCH
191 = check (integral_args <= 32) err
193 integral_args = sum [ (widthInBytes . argMachRep . primRepToCgRep) prim_rep
194 | prim_rep <- map typePrimRep arg_tys,
195 primRepHint prim_rep /= FloatHint ]
196 err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
198 checkFEDArgs _ = return ()
203 %************************************************************************
207 %************************************************************************
210 tcForeignExports :: [LForeignDecl Name]
211 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
212 tcForeignExports decls
213 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
215 combine (binds, fs) fe = do
216 (b, f) <- wrapLocSndM tcFExport fe
217 return (b `consBag` binds, f:fs)
219 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
220 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
221 addErrCtxt (foreignDeclCtxt fo) $ do
223 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
224 rhs <- tcPolyExpr (nlHsVar nm) sig_ty
226 tcCheckFEType sig_ty spec
228 -- we're exporting a function, but at a type possibly more
229 -- constrained than its declared/inferred type. Hence the need
230 -- to create a local binding which will call the exported function
231 -- at a particular type (and, maybe, overloading).
234 -- We need to give a name to the new top-level binding that
235 -- is *stable* (i.e. the compiler won't change it later),
236 -- because this name will be referred to by the C code stub.
237 id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
238 return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
239 tcFExport d = pprPanic "tcFExport" (ppr d)
242 ------------ Checking argument types for foreign export ----------------------
245 tcCheckFEType :: Type -> ForeignExport -> TcM ()
246 tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
247 check (isCLabelString str) (badCName str)
248 checkForeignArgs isFFIExternalTy arg_tys
249 checkForeignRes nonIOok isFFIExportResultTy res_ty
251 -- Drop the foralls before inspecting n
252 -- the structure of the foreign type.
253 (_, t_ty) = tcSplitForAllTys sig_ty
254 (arg_tys, res_ty) = tcSplitFunTys t_ty
255 tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
260 %************************************************************************
262 \subsection{Miscellaneous}
264 %************************************************************************
267 ------------ Checking argument types for foreign import ----------------------
268 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
269 checkForeignArgs pred tys
272 go ty = check (pred ty) (illegalForeignTyErr argument ty)
274 ------------ Checking result types for foreign calls ----------------------
275 -- Check that the type has the form
276 -- (IO t) or (t) , and that t satisfies the given predicate.
278 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
280 nonIOok, mustBeIO :: Bool
284 checkForeignRes non_io_result_ok pred_res_ty ty
285 -- (IO t) is ok, and so is any newtype wrapping thereof
286 | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
291 = check (non_io_result_ok && pred_res_ty ty)
292 (illegalForeignTyErr result ty)
296 checkDotnet :: HscTarget -> Maybe SDoc
297 #if defined(mingw32_TARGET_OS)
298 checkDotnet HscC = Nothing
299 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
301 checkDotnet _ = Just (text "requires .NET support (-filx or win32)")
304 checkCOrAsm :: HscTarget -> Maybe SDoc
305 checkCOrAsm HscC = Nothing
306 checkCOrAsm HscAsm = Nothing
308 = Just (text "requires via-C or native code generation (-fvia-C)")
310 checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
311 checkCOrAsmOrInterp HscC = Nothing
312 checkCOrAsmOrInterp HscAsm = Nothing
313 checkCOrAsmOrInterp HscInterpreted = Nothing
314 checkCOrAsmOrInterp _
315 = Just (text "requires interpreted, C or native code generation")
317 checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
318 checkCOrAsmOrDotNetOrInterp HscC = Nothing
319 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
320 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
321 checkCOrAsmOrDotNetOrInterp _
322 = Just (text "requires interpreted, C or native code generation")
324 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
327 let target = hscTarget dflags
329 HscNothing -> return ()
333 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
339 checkCConv :: CCallConv -> TcM ()
340 checkCConv CCallConv = return ()
342 checkCConv StdCallConv = return ()
344 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
346 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
352 check :: Bool -> Message -> TcM ()
353 check True _ = return ()
354 check _ the_err = addErrTc the_err
356 illegalForeignTyErr :: SDoc -> Type -> SDoc
357 illegalForeignTyErr arg_or_res ty
358 = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
359 ptext (sLit "type in foreign declaration:")])
362 -- Used for 'arg_or_res' argument to illegalForeignTyErr
363 argument, result :: SDoc
364 argument = text "argument"
365 result = text "result"
367 badCName :: CLabelString -> Message
369 = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
371 foreignDeclCtxt :: ForeignDecl Name -> SDoc
373 = hang (ptext (sLit "When checking declaration:"))
376 illegalDNMethodSig :: SDoc
378 = ptext (sLit "'This pointer' expected as last argument")