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"
50 isForeignImport :: LForeignDecl name -> Bool
51 isForeignImport (L _ (ForeignImport _ _ _)) = True
52 isForeignImport _ = False
55 isForeignExport :: LForeignDecl name -> Bool
56 isForeignExport (L _ (ForeignExport _ _ _)) = True
57 isForeignExport _ = False
60 %************************************************************************
64 %************************************************************************
67 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
68 tcForeignImports decls
69 = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
71 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
72 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
73 = addErrCtxt (foreignDeclCtxt fo) $ do
74 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
76 -- drop the foralls before inspecting the structure
77 -- of the foreign type.
78 (_, t_ty) = tcSplitForAllTys sig_ty
79 (arg_tys, res_ty) = tcSplitFunTys t_ty
80 id = mkLocalId nm sig_ty
81 -- Use a LocalId to obey the invariant that locally-defined
82 -- things are LocalIds. However, it does not need zonking,
83 -- (so TcHsSyn.zonkForeignExports ignores it).
85 imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
86 -- can't use sig_ty here because it :: Type and we need HsType Id
87 -- hence the undefined
88 return (id, ForeignImport (L loc id) undefined imp_decl')
89 tcFImport d = pprPanic "tcFImport" (ppr d)
93 ------------ Checking types for foreign import ----------------------
95 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
96 tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
99 checkForeignArgs (isFFIDotnetTy dflags) arg_tys
100 checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
101 let (DNCallSpec isStatic kind _ _ _ _) = spec
103 DNMethod | not isStatic ->
105 [] -> addErrTc illegalDNMethodSig
107 | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
108 | otherwise -> return ()
110 return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
112 tcCheckFIType sig_ty _ _ idecl@(CImport _ _ _ _ (CLabel _)) = do
114 check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
117 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
118 -- Foreign wrapper (former f.e.d.)
119 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
120 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
121 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
122 -- is DEPRECATED, though.
123 checkCg checkCOrAsmOrInterp
126 [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
127 checkForeignRes nonIOok isFFIExportResultTy res1_ty
128 checkForeignRes mustBeIO isFFIDynResultTy res_ty
129 checkFEDArgs arg1_tys
131 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
132 _ -> addErrTc (illegalForeignTyErr empty sig_ty)
135 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
136 | isDynamicTarget target = do -- Foreign import dynamic
137 checkCg checkCOrAsmOrInterp
139 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
141 check False (illegalForeignTyErr empty sig_ty)
143 (arg1_ty:arg_tys) -> do
145 check (isFFIDynArgumentTy arg1_ty)
146 (illegalForeignTyErr argument arg1_ty)
147 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
148 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
150 | otherwise = do -- Normal foreign import
151 checkCg (checkCOrAsmOrDotNetOrInterp)
155 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
156 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
157 checkMissingAmpersand dflags arg_tys res_ty
160 -- This makes a convenient place to check
161 -- that the C identifier is valid for C
162 checkCTarget :: CCallTarget -> TcM ()
163 checkCTarget (StaticTarget str) = do
164 checkCg checkCOrAsmOrDotNetOrInterp
165 check (isCLabelString str) (badCName str)
166 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
168 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
169 checkMissingAmpersand dflags arg_tys res_ty
170 | null arg_tys && isFunPtrTy res_ty &&
171 dopt Opt_WarnDodgyForeignImports dflags
172 = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
177 On an Alpha, with foreign export dynamic, due to a giant hack when
178 building adjustor thunks, we only allow 4 integer arguments with
179 foreign export dynamic (i.e., 32 bytes of arguments after padding each
180 argument to a quadword, excluding floating-point arguments).
182 The check is needed for both via-C and native-code routes
185 #include "nativeGen/NCG.h"
187 checkFEDArgs :: [Type] -> TcM ()
188 #if alpha_TARGET_ARCH
190 = check (integral_args <= 32) err
192 integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
193 | prim_rep <- map typePrimRep arg_tys,
194 primRepHint prim_rep /= FloatHint ]
195 err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
197 checkFEDArgs _ = return ()
202 %************************************************************************
206 %************************************************************************
209 tcForeignExports :: [LForeignDecl Name]
210 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
211 tcForeignExports decls
212 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
214 combine (binds, fs) fe = do
215 (b, f) <- wrapLocSndM tcFExport fe
216 return (b `consBag` binds, f:fs)
218 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
219 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
220 addErrCtxt (foreignDeclCtxt fo) $ do
222 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
223 rhs <- tcPolyExpr (nlHsVar nm) sig_ty
225 tcCheckFEType sig_ty spec
227 -- we're exporting a function, but at a type possibly more
228 -- constrained than its declared/inferred type. Hence the need
229 -- to create a local binding which will call the exported function
230 -- at a particular type (and, maybe, overloading).
235 -- We need to give a name to the new top-level binding that
236 -- is *stable* (i.e. the compiler won't change it later),
237 -- because this name will be referred to by the C code stub.
238 -- Furthermore, the name must be unique (see #1533). If the
239 -- same function is foreign-exported multiple times, the
240 -- top-level bindings generated must not have the same name.
241 -- Hence we create an External name (doesn't change), and we
242 -- append a Unique to the string right here.
243 uniq_str = showSDoc (pprUnique uniq)
244 occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
245 gnm = mkExternalName uniq mod (mkForeignExportOcc occ) loc
246 id = mkExportedLocalId gnm sig_ty
247 bind = L loc (VarBind id rhs)
249 return (bind, ForeignExport (L loc id) undefined spec)
250 tcFExport d = pprPanic "tcFExport" (ppr d)
253 ------------ Checking argument types for foreign export ----------------------
256 tcCheckFEType :: Type -> ForeignExport -> TcM ()
257 tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
258 check (isCLabelString str) (badCName str)
259 checkForeignArgs isFFIExternalTy arg_tys
260 checkForeignRes nonIOok isFFIExportResultTy res_ty
262 -- Drop the foralls before inspecting n
263 -- the structure of the foreign type.
264 (_, t_ty) = tcSplitForAllTys sig_ty
265 (arg_tys, res_ty) = tcSplitFunTys t_ty
266 tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
271 %************************************************************************
273 \subsection{Miscellaneous}
275 %************************************************************************
278 ------------ Checking argument types for foreign import ----------------------
279 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
280 checkForeignArgs pred tys
283 go ty = check (pred ty) (illegalForeignTyErr argument ty)
285 ------------ Checking result types for foreign calls ----------------------
286 -- Check that the type has the form
287 -- (IO t) or (t) , and that t satisfies the given predicate.
289 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
291 nonIOok, mustBeIO :: Bool
295 checkForeignRes non_io_result_ok pred_res_ty ty
296 -- (IO t) is ok, and so is any newtype wrapping thereof
297 | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
302 = check (non_io_result_ok && pred_res_ty ty)
303 (illegalForeignTyErr result ty)
307 checkDotnet :: HscTarget -> Maybe SDoc
308 #if defined(mingw32_TARGET_OS)
309 checkDotnet HscC = Nothing
310 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
312 checkDotnet _ = Just (text "requires .NET support (-filx or win32)")
315 checkCOrAsm :: HscTarget -> Maybe SDoc
316 checkCOrAsm HscC = Nothing
317 checkCOrAsm HscAsm = Nothing
319 = Just (text "requires via-C or native code generation (-fvia-C)")
321 checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
322 checkCOrAsmOrInterp HscC = Nothing
323 checkCOrAsmOrInterp HscAsm = Nothing
324 checkCOrAsmOrInterp HscInterpreted = Nothing
325 checkCOrAsmOrInterp _
326 = Just (text "requires interpreted, C or native code generation")
328 checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
329 checkCOrAsmOrDotNetOrInterp HscC = Nothing
330 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
331 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
332 checkCOrAsmOrDotNetOrInterp _
333 = Just (text "requires interpreted, C or native code generation")
335 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
338 let target = hscTarget dflags
340 HscNothing -> return ()
344 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
350 checkCConv :: CCallConv -> TcM ()
351 checkCConv CCallConv = return ()
353 checkCConv StdCallConv = return ()
355 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
357 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
363 check :: Bool -> Message -> TcM ()
364 check True _ = return ()
365 check _ the_err = addErrTc the_err
367 illegalForeignTyErr :: SDoc -> Type -> SDoc
368 illegalForeignTyErr arg_or_res ty
369 = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
370 ptext (sLit "type in foreign declaration:")])
373 -- Used for 'arg_or_res' argument to illegalForeignTyErr
374 argument, result :: SDoc
375 argument = text "argument"
376 result = text "result"
378 badCName :: CLabelString -> Message
380 = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
382 foreignDeclCtxt :: ForeignDecl Name -> SDoc
384 = hang (ptext (sLit "When checking declaration:"))
387 illegalDNMethodSig :: SDoc
389 = ptext (sLit "'This pointer' expected as last argument")