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.
16 -- The above warning supression flag is a temporary kludge.
17 -- While working on this module you are encouraged to remove it and fix
18 -- any warnings in the module. See
19 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
28 #include "HsVersions.h"
56 isForeignImport :: LForeignDecl name -> Bool
57 isForeignImport (L _ (ForeignImport _ _ _)) = True
58 isForeignImport _ = False
61 isForeignExport :: LForeignDecl name -> Bool
62 isForeignExport (L _ (ForeignExport _ _ _)) = True
63 isForeignExport _ = False
66 %************************************************************************
70 %************************************************************************
73 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
74 tcForeignImports decls
75 = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
77 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
78 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
79 = addErrCtxt (foreignDeclCtxt fo) $
80 tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
82 -- drop the foralls before inspecting the structure
83 -- of the foreign type.
84 (_, t_ty) = tcSplitForAllTys sig_ty
85 (arg_tys, res_ty) = tcSplitFunTys t_ty
86 id = mkLocalId nm sig_ty
87 -- Use a LocalId to obey the invariant that locally-defined
88 -- things are LocalIds. However, it does not need zonking,
89 -- (so TcHsSyn.zonkForeignExports ignores it).
91 tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
92 -- can't use sig_ty here because it :: Type and we need HsType Id
93 -- hence the undefined
94 returnM (id, ForeignImport (L loc id) undefined imp_decl')
98 ------------ Checking types for foreign import ----------------------
100 tcCheckFIType _ arg_tys res_ty (DNImport spec)
101 = checkCg checkDotnet `thenM_`
102 getDOpts `thenM` \ dflags ->
103 checkForeignArgs (isFFIDotnetTy dflags) arg_tys `thenM_`
104 checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
105 let (DNCallSpec isStatic kind _ _ _ _) = spec in
107 DNMethod | not isStatic ->
109 [] -> addErrTc illegalDNMethodSig
111 | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
112 | otherwise -> returnM ()
113 _ -> returnM ()) `thenM_`
114 returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
116 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
117 = checkCg checkCOrAsm `thenM_`
118 check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
121 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
122 = -- Foreign wrapper (former f.e.d.)
123 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
124 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
125 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
126 -- is DEPRECATED, though.
127 checkCg checkCOrAsmOrInterp `thenM_`
128 checkCConv cconv `thenM_`
130 [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
131 checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
132 checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_`
133 checkFEDArgs arg1_tys
135 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
136 other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_`
139 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
140 | isDynamicTarget target -- Foreign import dynamic
141 = checkCg checkCOrAsmOrInterp `thenM_`
142 checkCConv cconv `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 checkCConv cconv `thenM_`
157 checkCTarget target `thenM_`
158 getDOpts `thenM` \ dflags ->
159 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
160 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
163 -- This makes a convenient place to check
164 -- that the C identifier is valid for C
165 checkCTarget (StaticTarget str)
166 = checkCg checkCOrAsmOrDotNetOrInterp `thenM_`
167 check (isCLabelString str) (badCName str)
170 On an Alpha, with foreign export dynamic, due to a giant hack when
171 building adjustor thunks, we only allow 4 integer arguments with
172 foreign export dynamic (i.e., 32 bytes of arguments after padding each
173 argument to a quadword, excluding floating-point arguments).
175 The check is needed for both via-C and native-code routes
178 #include "nativeGen/NCG.h"
179 #if alpha_TARGET_ARCH
181 = check (integral_args <= 32) err
183 integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
184 | prim_rep <- map typePrimRep arg_tys,
185 primRepHint prim_rep /= FloatHint ]
186 err = ptext SLIT("On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
188 checkFEDArgs arg_tys = returnM ()
193 %************************************************************************
197 %************************************************************************
200 tcForeignExports :: [LForeignDecl Name]
201 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
202 tcForeignExports decls
203 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
205 combine (binds, fs) fe =
206 wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
207 returnM (b `consBag` binds, f:fs)
209 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
210 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
211 addErrCtxt (foreignDeclCtxt fo) $
213 tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
214 tcPolyExpr (nlHsVar nm) sig_ty `thenM` \ rhs ->
216 tcCheckFEType sig_ty spec `thenM_`
218 -- we're exporting a function, but at a type possibly more
219 -- constrained than its declared/inferred type. Hence the need
220 -- to create a local binding which will call the exported function
221 -- at a particular type (and, maybe, overloading).
223 newUnique `thenM` \ uniq ->
224 getModule `thenM` \ mod ->
226 -- We need to give a name to the new top-level binding that
227 -- is *stable* (i.e. the compiler won't change it later),
228 -- because this name will be referred to by the C code stub.
229 -- Furthermore, the name must be unique (see #1533). If the
230 -- same function is foreign-exported multiple times, the
231 -- top-level bindings generated must not have the same name.
232 -- Hence we create an External name (doesn't change), and we
233 -- append a Unique to the string right here.
234 uniq_str = showSDoc (pprUnique uniq)
235 occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
236 gnm = mkExternalName uniq mod (mkForeignExportOcc occ) loc
237 id = mkExportedLocalId gnm sig_ty
238 bind = L loc (VarBind id rhs)
240 returnM (bind, ForeignExport (L loc id) undefined spec)
243 ------------ Checking argument types for foreign export ----------------------
246 tcCheckFEType sig_ty (CExport (CExportStatic str _))
247 = check (isCLabelString str) (badCName str) `thenM_`
248 checkForeignArgs isFFIExternalTy arg_tys `thenM_`
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
259 %************************************************************************
261 \subsection{Miscellaneous}
263 %************************************************************************
266 ------------ Checking argument types for foreign import ----------------------
267 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
268 checkForeignArgs pred tys
269 = mappM go tys `thenM_`
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 ()
283 checkForeignRes non_io_result_ok pred_res_ty ty
284 -- (IO t) is ok, and so is any newtype wrapping thereof
285 | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
290 = check (non_io_result_ok && pred_res_ty ty)
291 (illegalForeignTyErr result ty)
295 #if defined(mingw32_TARGET_OS)
296 checkDotnet HscC = Nothing
297 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
299 checkDotnet other = Just (text "requires .NET support (-filx or win32)")
302 checkCOrAsm HscC = Nothing
303 checkCOrAsm HscAsm = Nothing
305 = Just (text "requires via-C or native code generation (-fvia-C)")
307 checkCOrAsmOrInterp HscC = Nothing
308 checkCOrAsmOrInterp HscAsm = Nothing
309 checkCOrAsmOrInterp HscInterpreted = Nothing
310 checkCOrAsmOrInterp other
311 = Just (text "requires interpreted, C or native code generation")
313 checkCOrAsmOrDotNetOrInterp HscC = Nothing
314 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
315 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
316 checkCOrAsmOrDotNetOrInterp other
317 = Just (text "requires interpreted, C or native code generation")
320 = getDOpts `thenM` \ dflags ->
321 let target = hscTarget dflags in
323 HscNothing -> returnM ()
326 Nothing -> returnM ()
327 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
333 checkCConv :: CCallConv -> TcM ()
334 checkCConv CCallConv = return ()
336 checkCConv StdCallConv = return ()
338 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
345 check :: Bool -> Message -> TcM ()
346 check True _ = returnM ()
347 check _ the_err = addErrTc the_err
349 illegalForeignTyErr arg_or_res ty
350 = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
351 ptext SLIT("type in foreign declaration:")])
354 -- Used for 'arg_or_res' argument to illegalForeignTyErr
355 argument = text "argument"
356 result = text "result"
358 badCName :: CLabelString -> Message
360 = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
363 = hang (ptext SLIT("When checking declaration:"))
367 = ptext SLIT("'This pointer' expected as last argument")