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
55 isForeignImport :: LForeignDecl name -> Bool
56 isForeignImport (L _ (ForeignImport _ _ _)) = True
57 isForeignImport _ = False
60 isForeignExport :: LForeignDecl name -> Bool
61 isForeignExport (L _ (ForeignExport _ _ _)) = True
62 isForeignExport _ = False
65 %************************************************************************
69 %************************************************************************
72 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
73 tcForeignImports decls
74 = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
76 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
77 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
78 = addErrCtxt (foreignDeclCtxt fo) $ do
79 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
81 -- drop the foralls before inspecting the structure
82 -- of the foreign type.
83 (_, t_ty) = tcSplitForAllTys sig_ty
84 (arg_tys, res_ty) = tcSplitFunTys t_ty
85 id = mkLocalId nm sig_ty
86 -- Use a LocalId to obey the invariant that locally-defined
87 -- things are LocalIds. However, it does not need zonking,
88 -- (so TcHsSyn.zonkForeignExports ignores it).
90 imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
91 -- can't use sig_ty here because it :: Type and we need HsType Id
92 -- hence the undefined
93 return (id, ForeignImport (L loc id) undefined imp_decl')
97 ------------ Checking types for foreign import ----------------------
99 tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
102 checkForeignArgs (isFFIDotnetTy dflags) arg_tys
103 checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
104 let (DNCallSpec isStatic kind _ _ _ _) = spec
106 DNMethod | not isStatic ->
108 [] -> addErrTc illegalDNMethodSig
110 | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
111 | otherwise -> return ()
113 return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
115 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = do
117 check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
120 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
121 -- Foreign wrapper (former f.e.d.)
122 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
123 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
124 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
125 -- is DEPRECATED, though.
126 checkCg checkCOrAsmOrInterp
129 [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
130 checkForeignRes nonIOok isFFIExportResultTy res1_ty
131 checkForeignRes mustBeIO isFFIDynResultTy res_ty
132 checkFEDArgs arg1_tys
134 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
135 other -> addErrTc (illegalForeignTyErr empty sig_ty)
138 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
139 | isDynamicTarget target = do -- Foreign import dynamic
140 checkCg checkCOrAsmOrInterp
142 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
144 check False (illegalForeignTyErr empty sig_ty)
146 (arg1_ty:arg_tys) -> do
148 check (isFFIDynArgumentTy arg1_ty)
149 (illegalForeignTyErr argument arg1_ty)
150 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
151 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
153 | otherwise = do -- Normal foreign import
154 checkCg (checkCOrAsmOrDotNetOrInterp)
158 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
159 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
162 -- This makes a convenient place to check
163 -- that the C identifier is valid for C
164 checkCTarget (StaticTarget str) = do
165 checkCg checkCOrAsmOrDotNetOrInterp
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 <= 32) err
182 integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
183 | prim_rep <- map typePrimRep arg_tys,
184 primRepHint prim_rep /= FloatHint ]
185 err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
187 checkFEDArgs arg_tys = return ()
192 %************************************************************************
196 %************************************************************************
199 tcForeignExports :: [LForeignDecl Name]
200 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
201 tcForeignExports decls
202 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
204 combine (binds, fs) fe = do
205 (b, f) <- wrapLocSndM tcFExport fe
206 return (b `consBag` binds, f:fs)
208 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
209 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
210 addErrCtxt (foreignDeclCtxt fo) $ do
212 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
213 rhs <- tcPolyExpr (nlHsVar nm) sig_ty
215 tcCheckFEType sig_ty spec
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).
225 -- We need to give a name to the new top-level binding that
226 -- is *stable* (i.e. the compiler won't change it later),
227 -- because this name will be referred to by the C code stub.
228 -- Furthermore, the name must be unique (see #1533). If the
229 -- same function is foreign-exported multiple times, the
230 -- top-level bindings generated must not have the same name.
231 -- Hence we create an External name (doesn't change), and we
232 -- append a Unique to the string right here.
233 uniq_str = showSDoc (pprUnique uniq)
234 occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
235 gnm = mkExternalName uniq mod (mkForeignExportOcc occ) loc
236 id = mkExportedLocalId gnm sig_ty
237 bind = L loc (VarBind id rhs)
239 return (bind, ForeignExport (L loc id) undefined spec)
242 ------------ Checking argument types for foreign export ----------------------
245 tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
246 check (isCLabelString str) (badCName str)
247 checkForeignArgs isFFIExternalTy arg_tys
248 checkForeignRes nonIOok isFFIExportResultTy res_ty
250 -- Drop the foralls before inspecting n
251 -- the structure of the foreign type.
252 (_, t_ty) = tcSplitForAllTys sig_ty
253 (arg_tys, res_ty) = tcSplitFunTys t_ty
258 %************************************************************************
260 \subsection{Miscellaneous}
262 %************************************************************************
265 ------------ Checking argument types for foreign import ----------------------
266 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
267 checkForeignArgs pred tys
270 go ty = check (pred ty) (illegalForeignTyErr argument ty)
272 ------------ Checking result types for foreign calls ----------------------
273 -- Check that the type has the form
274 -- (IO t) or (t) , and that t satisfies the given predicate.
276 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
281 checkForeignRes non_io_result_ok pred_res_ty ty
282 -- (IO t) is ok, and so is any newtype wrapping thereof
283 | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
288 = check (non_io_result_ok && pred_res_ty ty)
289 (illegalForeignTyErr result ty)
293 #if defined(mingw32_TARGET_OS)
294 checkDotnet HscC = Nothing
295 checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
297 checkDotnet other = Just (text "requires .NET support (-filx or win32)")
300 checkCOrAsm HscC = Nothing
301 checkCOrAsm HscAsm = Nothing
303 = Just (text "requires via-C or native code generation (-fvia-C)")
305 checkCOrAsmOrInterp HscC = Nothing
306 checkCOrAsmOrInterp HscAsm = Nothing
307 checkCOrAsmOrInterp HscInterpreted = Nothing
308 checkCOrAsmOrInterp other
309 = Just (text "requires interpreted, C or native code generation")
311 checkCOrAsmOrDotNetOrInterp HscC = Nothing
312 checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
313 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
314 checkCOrAsmOrDotNetOrInterp other
315 = Just (text "requires interpreted, C or native code generation")
319 let target = hscTarget dflags
321 HscNothing -> return ()
325 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
331 checkCConv :: CCallConv -> TcM ()
332 checkCConv CCallConv = return ()
334 checkCConv StdCallConv = return ()
336 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
343 check :: Bool -> Message -> TcM ()
344 check True _ = return ()
345 check _ the_err = addErrTc the_err
347 illegalForeignTyErr arg_or_res ty
348 = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
349 ptext (sLit "type in foreign declaration:")])
352 -- Used for 'arg_or_res' argument to illegalForeignTyErr
353 argument = text "argument"
354 result = text "result"
356 badCName :: CLabelString -> Message
358 = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
361 = hang (ptext (sLit "When checking declaration:"))
365 = ptext (sLit "'This pointer' expected as last argument")