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 tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
75 -- drop the foralls before inspecting the structure
76 -- 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 tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
85 -- can't use sig_ty here because it :: Type and we need HsType Id
86 -- hence the undefined
87 returnM (id, ForeignImport (L loc id) undefined imp_decl')
91 ------------ Checking types for foreign import ----------------------
93 tcCheckFIType _ arg_tys res_ty (DNImport spec)
94 = checkCg checkDotnet `thenM_`
95 getDOpts `thenM` \ dflags ->
96 checkForeignArgs (isFFIDotnetTy dflags) arg_tys `thenM_`
97 checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
98 let (DNCallSpec isStatic kind _ _ _ _) = spec in
100 DNMethod | not isStatic ->
102 [] -> addErrTc illegalDNMethodSig
104 | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
105 | otherwise -> returnM ()
106 _ -> returnM ()) `thenM_`
107 returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
109 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
110 = checkCg checkCOrAsm `thenM_`
111 check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
114 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
115 = -- Foreign wrapper (former f.e.d.)
116 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
117 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
118 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
119 -- is DEPRECATED, though.
120 checkCg checkCOrAsmOrInterp `thenM_`
121 checkCConv cconv `thenM_`
123 [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
124 checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
125 checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_`
126 checkFEDArgs arg1_tys
128 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
129 other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_`
132 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
133 | isDynamicTarget target -- Foreign import dynamic
134 = checkCg checkCOrAsmOrInterp `thenM_`
135 checkCConv cconv `thenM_`
136 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
138 check False (illegalForeignTyErr empty sig_ty) `thenM_`
141 getDOpts `thenM` \ dflags ->
142 check (isFFIDynArgumentTy arg1_ty)
143 (illegalForeignTyErr argument arg1_ty) `thenM_`
144 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
145 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
147 | otherwise -- Normal foreign import
148 = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_`
149 checkCConv cconv `thenM_`
150 checkCTarget target `thenM_`
151 getDOpts `thenM` \ dflags ->
152 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
153 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
156 -- This makes a convenient place to check
157 -- that the C identifier is valid for C
158 checkCTarget (StaticTarget str)
159 = checkCg checkCOrAsmOrDotNetOrInterp `thenM_`
160 check (isCLabelString str) (badCName str)
163 On an Alpha, with foreign export dynamic, due to a giant hack when
164 building adjustor thunks, we only allow 4 integer arguments with
165 foreign export dynamic (i.e., 32 bytes of arguments after padding each
166 argument to a quadword, excluding floating-point arguments).
168 The check is needed for both via-C and native-code routes
171 #include "nativeGen/NCG.h"
172 #if alpha_TARGET_ARCH
174 = check (integral_args <= 32) err
176 integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
177 | prim_rep <- map typePrimRep arg_tys,
178 primRepHint prim_rep /= FloatHint ]
179 err = ptext SLIT("On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
181 checkFEDArgs arg_tys = returnM ()
186 %************************************************************************
190 %************************************************************************
193 tcForeignExports :: [LForeignDecl Name]
194 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
195 tcForeignExports decls
196 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
198 combine (binds, fs) fe =
199 wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
200 returnM (b `consBag` binds, f:fs)
202 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
203 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
204 addErrCtxt (foreignDeclCtxt fo) $
206 tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
207 tcPolyExpr (nlHsVar nm) sig_ty `thenM` \ rhs ->
209 tcCheckFEType sig_ty spec `thenM_`
211 -- we're exporting a function, but at a type possibly more
212 -- constrained than its declared/inferred type. Hence the need
213 -- to create a local binding which will call the exported function
214 -- at a particular type (and, maybe, overloading).
216 newUnique `thenM` \ uniq ->
217 getModule `thenM` \ mod ->
219 -- We need to give a name to the new top-level binding that
220 -- is *stable* (i.e. the compiler won't change it later),
221 -- because this name will be referred to by the C code stub.
222 -- Furthermore, the name must be unique (see #1533). If the
223 -- same function is foreign-exported multiple times, the
224 -- top-level bindings generated must not have the same name.
225 -- Hence we create an External name (doesn't change), and we
226 -- append a Unique to the string right here.
227 uniq_str = showSDoc (pprUnique uniq)
228 occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
229 gnm = mkExternalName uniq mod (mkForeignExportOcc occ) loc
230 id = mkExportedLocalId gnm sig_ty
231 bind = L loc (VarBind id rhs)
233 returnM (bind, ForeignExport (L loc id) undefined spec)
236 ------------ Checking argument types for foreign export ----------------------
239 tcCheckFEType sig_ty (CExport (CExportStatic str _))
240 = check (isCLabelString str) (badCName str) `thenM_`
241 checkForeignArgs isFFIExternalTy arg_tys `thenM_`
242 checkForeignRes nonIOok isFFIExportResultTy res_ty
244 -- Drop the foralls before inspecting n
245 -- the structure of the foreign type.
246 (_, t_ty) = tcSplitForAllTys sig_ty
247 (arg_tys, res_ty) = tcSplitFunTys t_ty
252 %************************************************************************
254 \subsection{Miscellaneous}
256 %************************************************************************
259 ------------ Checking argument types for foreign import ----------------------
260 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
261 checkForeignArgs pred tys
262 = mappM go tys `thenM_`
265 go ty = check (pred ty) (illegalForeignTyErr argument ty)
267 ------------ Checking result types for foreign calls ----------------------
268 -- Check that the type has the form
269 -- (IO t) or (t) , and that t satisfies the given predicate.
271 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
276 checkForeignRes non_io_result_ok pred_res_ty ty
277 -- (IO t) is ok, and so is any newtype wrapping thereof
278 | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
283 = check (non_io_result_ok && pred_res_ty ty)
284 (illegalForeignTyErr result ty)
288 #if defined(mingw32_TARGET_OS)
289 checkDotnet HscC = Nothing
290 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
292 checkDotnet other = Just (text "requires .NET support (-filx or win32)")
295 checkCOrAsm HscC = Nothing
296 checkCOrAsm HscAsm = Nothing
298 = Just (text "requires via-C or native code generation (-fvia-C)")
300 checkCOrAsmOrInterp HscC = Nothing
301 checkCOrAsmOrInterp HscAsm = Nothing
302 checkCOrAsmOrInterp HscInterpreted = Nothing
303 checkCOrAsmOrInterp other
304 = Just (text "requires interpreted, C or native code generation")
306 checkCOrAsmOrDotNetOrInterp HscC = Nothing
307 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
308 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
309 checkCOrAsmOrDotNetOrInterp other
310 = Just (text "requires interpreted, C or native code generation")
313 = getDOpts `thenM` \ dflags ->
314 let target = hscTarget dflags in
316 HscNothing -> returnM ()
319 Nothing -> returnM ()
320 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
326 checkCConv :: CCallConv -> TcM ()
327 checkCConv CCallConv = return ()
329 checkCConv StdCallConv = return ()
331 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
338 check :: Bool -> Message -> TcM ()
339 check True _ = returnM ()
340 check _ the_err = addErrTc the_err
342 illegalForeignTyErr arg_or_res ty
343 = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
344 ptext SLIT("type in foreign declaration:")])
347 -- Used for 'arg_or_res' argument to illegalForeignTyErr
348 argument = text "argument"
349 result = text "result"
351 badCName :: CLabelString -> Message
353 = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
356 = hang (ptext SLIT("When checking declaration:"))
360 = ptext SLIT("'This pointer' expected as last argument")