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"
47 isForeignImport :: LForeignDecl name -> Bool
48 isForeignImport (L _ (ForeignImport _ _ _)) = True
49 isForeignImport _ = False
52 isForeignExport :: LForeignDecl name -> Bool
53 isForeignExport (L _ (ForeignExport _ _ _)) = True
54 isForeignExport _ = False
57 %************************************************************************
61 %************************************************************************
64 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
65 tcForeignImports decls
66 = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
68 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
69 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
70 = addErrCtxt (foreignDeclCtxt fo) $
71 tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
73 -- drop the foralls before inspecting the structure
74 -- of the foreign type.
75 (_, t_ty) = tcSplitForAllTys sig_ty
76 (arg_tys, res_ty) = tcSplitFunTys t_ty
77 id = mkLocalId nm sig_ty
78 -- Use a LocalId to obey the invariant that locally-defined
79 -- things are LocalIds. However, it does not need zonking,
80 -- (so TcHsSyn.zonkForeignExports ignores it).
82 tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
83 -- can't use sig_ty here because it :: Type and we need HsType Id
84 -- hence the undefined
85 returnM (id, ForeignImport (L loc id) undefined imp_decl')
89 ------------ Checking types for foreign import ----------------------
91 tcCheckFIType _ arg_tys res_ty (DNImport spec)
92 = checkCg checkDotnet `thenM_`
93 getDOpts `thenM` \ dflags ->
94 checkForeignArgs (isFFIDotnetTy dflags) arg_tys `thenM_`
95 checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
96 let (DNCallSpec isStatic kind _ _ _ _) = spec in
98 DNMethod | not isStatic ->
100 [] -> addErrTc illegalDNMethodSig
102 | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
103 | otherwise -> returnM ()
104 _ -> returnM ()) `thenM_`
105 returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
107 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
108 = checkCg checkCOrAsm `thenM_`
109 check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
112 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
113 = -- Foreign wrapper (former f.e.d.)
114 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
115 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
116 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
117 -- is DEPRECATED, though.
118 checkCg checkCOrAsmOrInterp `thenM_`
119 checkCConv cconv `thenM_`
121 [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
122 checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
123 checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_`
124 checkFEDArgs arg1_tys
126 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
127 other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_`
130 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
131 | isDynamicTarget target -- Foreign import dynamic
132 = checkCg checkCOrAsmOrInterp `thenM_`
133 checkCConv cconv `thenM_`
134 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
136 check False (illegalForeignTyErr empty sig_ty) `thenM_`
139 getDOpts `thenM` \ dflags ->
140 check (isFFIDynArgumentTy arg1_ty)
141 (illegalForeignTyErr argument arg1_ty) `thenM_`
142 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
143 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
145 | otherwise -- Normal foreign import
146 = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_`
147 checkCConv cconv `thenM_`
148 checkCTarget target `thenM_`
149 getDOpts `thenM` \ dflags ->
150 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
151 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
154 -- This makes a convenient place to check
155 -- that the C identifier is valid for C
156 checkCTarget (StaticTarget str)
157 = checkCg checkCOrAsmOrDotNetOrInterp `thenM_`
158 check (isCLabelString str) (badCName str)
161 On an Alpha, with foreign export dynamic, due to a giant hack when
162 building adjustor thunks, we only allow 4 integer arguments with
163 foreign export dynamic (i.e., 32 bytes of arguments after padding each
164 argument to a quadword, excluding floating-point arguments).
166 The check is needed for both via-C and native-code routes
169 #include "nativeGen/NCG.h"
170 #if alpha_TARGET_ARCH
172 = check (integral_args <= 32) err
174 integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
175 | prim_rep <- map typePrimRep arg_tys,
176 primRepHint prim_rep /= FloatHint ]
177 err = ptext SLIT("On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
179 checkFEDArgs arg_tys = returnM ()
184 %************************************************************************
188 %************************************************************************
191 tcForeignExports :: [LForeignDecl Name]
192 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
193 tcForeignExports decls
194 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
196 combine (binds, fs) fe =
197 wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
198 returnM (b `consBag` binds, f:fs)
200 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
201 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
202 addErrCtxt (foreignDeclCtxt fo) $
204 tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
205 tcPolyExpr (nlHsVar nm) sig_ty `thenM` \ rhs ->
207 tcCheckFEType sig_ty spec `thenM_`
209 -- we're exporting a function, but at a type possibly more
210 -- constrained than its declared/inferred type. Hence the need
211 -- to create a local binding which will call the exported function
212 -- at a particular type (and, maybe, overloading).
214 newUnique `thenM` \ uniq ->
215 getModule `thenM` \ mod ->
217 gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) loc
218 id = mkExportedLocalId gnm sig_ty
219 bind = L loc (VarBind id rhs)
221 returnM (bind, ForeignExport (L loc id) undefined spec)
224 ------------ Checking argument types for foreign export ----------------------
227 tcCheckFEType sig_ty (CExport (CExportStatic str _))
228 = check (isCLabelString str) (badCName str) `thenM_`
229 checkForeignArgs isFFIExternalTy arg_tys `thenM_`
230 checkForeignRes nonIOok isFFIExportResultTy res_ty
232 -- Drop the foralls before inspecting n
233 -- the structure of the foreign type.
234 (_, t_ty) = tcSplitForAllTys sig_ty
235 (arg_tys, res_ty) = tcSplitFunTys t_ty
240 %************************************************************************
242 \subsection{Miscellaneous}
244 %************************************************************************
247 ------------ Checking argument types for foreign import ----------------------
248 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
249 checkForeignArgs pred tys
250 = mappM go tys `thenM_`
253 go ty = check (pred ty) (illegalForeignTyErr argument ty)
255 ------------ Checking result types for foreign calls ----------------------
256 -- Check that the type has the form
257 -- (IO t) or (t) , and that t satisfies the given predicate.
259 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
264 checkForeignRes non_io_result_ok pred_res_ty ty
265 -- (IO t) is ok, and so is any newtype wrapping thereof
266 | Just (io, res_ty) <- tcSplitIOType_maybe ty,
271 = check (non_io_result_ok && pred_res_ty ty)
272 (illegalForeignTyErr result ty)
276 #if defined(mingw32_TARGET_OS)
277 checkDotnet HscC = Nothing
278 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
280 checkDotnet other = Just (text "requires .NET support (-filx or win32)")
283 checkCOrAsm HscC = Nothing
284 checkCOrAsm HscAsm = Nothing
286 = Just (text "requires via-C or native code generation (-fvia-C)")
288 checkCOrAsmOrInterp HscC = Nothing
289 checkCOrAsmOrInterp HscAsm = Nothing
290 checkCOrAsmOrInterp HscInterpreted = Nothing
291 checkCOrAsmOrInterp other
292 = Just (text "requires interpreted, C or native code generation")
294 checkCOrAsmOrDotNetOrInterp HscC = Nothing
295 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
296 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
297 checkCOrAsmOrDotNetOrInterp other
298 = Just (text "requires interpreted, C or native code generation")
301 = getDOpts `thenM` \ dflags ->
302 let target = hscTarget dflags in
304 HscNothing -> returnM ()
307 Nothing -> returnM ()
308 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
314 checkCConv :: CCallConv -> TcM ()
315 checkCConv CCallConv = return ()
317 checkCConv StdCallConv = return ()
319 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
326 check :: Bool -> Message -> TcM ()
327 check True _ = returnM ()
328 check _ the_err = addErrTc the_err
330 illegalForeignTyErr arg_or_res ty
331 = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
332 ptext SLIT("type in foreign declaration:")])
335 -- Used for 'arg_or_res' argument to illegalForeignTyErr
336 argument = text "argument"
337 result = text "result"
339 badCName :: CLabelString -> Message
341 = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
344 = hang (ptext SLIT("When checking declaration:"))
348 = ptext SLIT("'This pointer' expected as last argument")