2 % (c) The AQUA Project, Glasgow University, 1998
4 \section[TcForeign]{Typechecking \tr{foreign} declarations}
6 A foreign declaration is used to either give an externally
7 implemented function a Haskell type (and calling interface) or
8 give a Haskell function an external calling interface. Either way,
9 the range of argument and result types these functions can accommodate
10 is restricted to what the outside world understands (read C), and this
11 module checks to see if a foreign declaration has got a legal type.
21 #include "HsVersions.h"
26 import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
27 import TcExpr ( tcCheckSigma )
29 import ErrUtils ( Message )
30 import Id ( Id, mkLocalId, mkExportedLocalId )
32 import PrimRep ( getPrimRepSize, isFloatingRep )
33 import Type ( typePrimRep )
35 import OccName ( mkForeignExportOcc )
36 import Name ( Name, NamedThing(..), mkExternalName )
37 import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
39 isFFIArgumentTy, isFFIImportResultTy,
40 isFFIExportResultTy, isFFILabelTy,
41 isFFIExternalTy, isFFIDynArgumentTy,
42 isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy,
45 import ForeignCall ( CExportSpec(..), CCallTarget(..),
46 isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
47 import CStrings ( CLabelString, isCLabelString )
48 import PrelNames ( hasKey, ioTyConKey )
49 import CmdLineOpts ( dopt_HscLang, HscLang(..) )
51 import SrcLoc ( Located(..), srcSpanStart )
52 import Bag ( emptyBag, consBag )
58 isForeignImport :: LForeignDecl name -> Bool
59 isForeignImport (L _ (ForeignImport _ _ _ _)) = True
60 isForeignImport _ = False
63 isForeignExport :: LForeignDecl name -> Bool
64 isForeignExport (L _ (ForeignExport _ _ _ _)) = True
65 isForeignExport _ = False
68 %************************************************************************
72 %************************************************************************
75 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
76 tcForeignImports decls
77 = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
79 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
80 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
81 = addErrCtxt (foreignDeclCtxt fo) $
82 tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
84 -- drop the foralls before inspecting the structure
85 -- of the foreign type.
86 (_, t_ty) = tcSplitForAllTys sig_ty
87 (arg_tys, res_ty) = tcSplitFunTys t_ty
88 id = mkLocalId nm sig_ty
89 -- Use a LocalId to obey the invariant that locally-defined
90 -- things are LocalIds. However, it does not need zonking,
91 -- (so TcHsSyn.zonkForeignExports ignores it).
93 tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
94 -- can't use sig_ty here because it :: Type and we need HsType Id
95 -- hence the undefined
96 returnM (id, ForeignImport (L loc id) undefined imp_decl' isDeprec)
100 ------------ Checking types for foreign import ----------------------
102 tcCheckFIType _ arg_tys res_ty (DNImport spec)
103 = checkCg checkDotnet `thenM_`
104 getDOpts `thenM` \ dflags ->
105 checkForeignArgs (isFFIDotnetTy dflags) arg_tys `thenM_`
106 checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
107 let (DNCallSpec isStatic kind _ _ _ _) = spec in
109 DNMethod | not isStatic ->
111 [] -> addErrTc illegalDNMethodSig
113 | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
114 | otherwise -> returnM ()
115 _ -> returnM ()) `thenM_`
116 returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
118 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
119 = checkCg checkCOrAsm `thenM_`
120 check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
123 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
124 = -- Foreign wrapper (former f.e.d.)
125 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
126 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
127 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
128 -- is DEPRECATED, though.
129 checkCg checkCOrAsmOrInterp `thenM_`
131 [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
132 checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
133 checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_`
134 checkFEDArgs arg1_tys
136 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
137 other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_`
140 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction target))
141 | isDynamicTarget target -- Foreign import dynamic
142 = checkCg checkCOrAsmOrInterp `thenM_`
143 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
145 check False (illegalForeignTyErr empty sig_ty) `thenM_`
148 getDOpts `thenM` \ dflags ->
149 check (isFFIDynArgumentTy arg1_ty)
150 (illegalForeignTyErr argument arg1_ty) `thenM_`
151 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
152 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
154 | otherwise -- Normal foreign import
155 = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_`
156 checkCTarget target `thenM_`
157 getDOpts `thenM` \ dflags ->
158 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
159 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
162 -- This makes a convenient place to check
163 -- that the C identifier is valid for C
164 checkCTarget (StaticTarget str)
165 = checkCg checkCOrAsmOrDotNetOrInterp `thenM_`
166 check (isCLabelString str) (badCName str)
169 On an Alpha, with foreign export dynamic, due to a giant hack when
170 building adjustor thunks, we only allow 4 integer arguments with
171 foreign export dynamic (i.e., 32 bytes of arguments after padding each
172 argument to a quadword, excluding floating-point arguments).
174 The check is needed for both via-C and native-code routes
177 #include "nativeGen/NCG.h"
178 #if alpha_TARGET_ARCH
180 = check (integral_args <= 4) err
182 integral_args = sum (map getPrimRepSize $
183 filter (not . isFloatingRep) $
184 map typePrimRep arg_tys)
185 err = ptext SLIT("On Alpha, I can only handle 4 non-floating-point arguments to foreign export dynamic")
187 checkFEDArgs arg_tys = returnM ()
192 %************************************************************************
196 %************************************************************************
199 tcForeignExports :: [LForeignDecl Name]
200 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
201 tcForeignExports decls
202 = foldlM combine (emptyBag, []) (filter isForeignExport decls)
204 combine (binds, fs) fe =
205 wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
206 returnM (b `consBag` binds, f:fs)
208 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
209 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
210 addErrCtxt (foreignDeclCtxt fo) $
212 tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
213 tcCheckSigma (nlHsVar nm) sig_ty `thenM` \ rhs ->
215 tcCheckFEType sig_ty spec `thenM_`
217 -- we're exporting a function, but at a type possibly more
218 -- constrained than its declared/inferred type. Hence the need
219 -- to create a local binding which will call the exported function
220 -- at a particular type (and, maybe, overloading).
222 newUnique `thenM` \ uniq ->
223 getModule `thenM` \ mod ->
225 gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm))
226 Nothing (srcSpanStart loc)
227 id = mkExportedLocalId gnm sig_ty
228 bind = L loc (VarBind id rhs)
230 returnM (bind, ForeignExport (L loc id) undefined spec isDeprec)
233 ------------ Checking argument types for foreign export ----------------------
236 tcCheckFEType sig_ty (CExport (CExportStatic str _))
237 = check (isCLabelString str) (badCName str) `thenM_`
238 checkForeignArgs isFFIExternalTy arg_tys `thenM_`
239 checkForeignRes nonIOok isFFIExportResultTy res_ty
241 -- Drop the foralls before inspecting n
242 -- the structure of the foreign type.
243 (_, t_ty) = tcSplitForAllTys sig_ty
244 (arg_tys, res_ty) = tcSplitFunTys t_ty
249 %************************************************************************
251 \subsection{Miscellaneous}
253 %************************************************************************
256 ------------ Checking argument types for foreign import ----------------------
257 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
258 checkForeignArgs pred tys
259 = mappM go tys `thenM_`
262 go ty = check (pred ty) (illegalForeignTyErr argument ty)
264 ------------ Checking result types for foreign calls ----------------------
265 -- Check that the type has the form
266 -- (IO t) or (t) , and that t satisfies the given predicate.
268 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
273 checkForeignRes non_io_result_ok pred_res_ty ty
274 = case tcSplitTyConApp_maybe ty of
276 | io `hasKey` ioTyConKey && pred_res_ty res_ty
279 -> check (non_io_result_ok && pred_res_ty ty)
280 (illegalForeignTyErr result ty)
284 checkDotnet HscILX = Nothing
285 #if defined(mingw32_TARGET_OS)
286 checkDotnet HscC = Nothing
287 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
289 checkDotnet other = Just (text "requires .NET support (-filx or win32)")
292 checkCOrAsm HscC = Nothing
293 checkCOrAsm HscAsm = Nothing
295 = Just (text "requires via-C or native code generation (-fvia-C)")
297 checkCOrAsmOrInterp HscC = Nothing
298 checkCOrAsmOrInterp HscAsm = Nothing
299 checkCOrAsmOrInterp HscInterpreted = Nothing
300 checkCOrAsmOrInterp other
301 = Just (text "requires interpreted, C or native code generation")
303 checkCOrAsmOrDotNetOrInterp HscC = Nothing
304 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
305 checkCOrAsmOrDotNetOrInterp HscILX = Nothing
306 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
307 checkCOrAsmOrDotNetOrInterp other
308 = Just (text "requires interpreted, C, native or .NET ILX code generation")
311 = getDOpts `thenM` \ dflags ->
312 let hscLang = dopt_HscLang dflags in
314 HscNothing -> returnM ()
316 case check hscLang of
317 Nothing -> returnM ()
318 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
324 check :: Bool -> Message -> TcM ()
325 check True _ = returnM ()
326 check _ the_err = addErrTc the_err
328 illegalForeignTyErr arg_or_res ty
329 = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
330 ptext SLIT("type in foreign declaration:")])
333 -- Used for 'arg_or_res' argument to illegalForeignTyErr
334 argument = text "argument"
335 result = text "result"
337 badCName :: CLabelString -> Message
339 = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
342 = hang (ptext SLIT("When checking declaration:"))
346 = ptext SLIT("'This pointer' expected as last argument")