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"
57 isForeignImport :: LForeignDecl name -> Bool
58 isForeignImport (L _ (ForeignImport _ _ _)) = True
59 isForeignImport _ = False
62 isForeignExport :: LForeignDecl name -> Bool
63 isForeignExport (L _ (ForeignExport _ _ _)) = True
64 isForeignExport _ = False
67 %************************************************************************
71 %************************************************************************
74 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
75 tcForeignImports decls
76 = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
78 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
79 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
80 = addErrCtxt (foreignDeclCtxt fo) $ do
81 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
83 -- drop the foralls before inspecting the structure
84 -- of the foreign type.
85 (_, t_ty) = tcSplitForAllTys sig_ty
86 (arg_tys, res_ty) = tcSplitFunTys t_ty
87 id = mkLocalId nm sig_ty
88 -- Use a LocalId to obey the invariant that locally-defined
89 -- things are LocalIds. However, it does not need zonking,
90 -- (so TcHsSyn.zonkForeignExports ignores it).
92 imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
93 -- can't use sig_ty here because it :: Type and we need HsType Id
94 -- hence the undefined
95 return (id, ForeignImport (L loc id) undefined imp_decl')
99 ------------ Checking types for foreign import ----------------------
101 tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
104 checkForeignArgs (isFFIDotnetTy dflags) arg_tys
105 checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
106 let (DNCallSpec isStatic kind _ _ _ _) = spec
108 DNMethod | not isStatic ->
110 [] -> addErrTc illegalDNMethodSig
112 | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
113 | otherwise -> return ()
115 return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
117 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = do
119 check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
122 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
123 -- Foreign wrapper (former f.e.d.)
124 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
125 -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
126 -- as ft -> IO Addr is accepted, too. The use of the latter two forms
127 -- is DEPRECATED, though.
128 checkCg checkCOrAsmOrInterp
131 [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
132 checkForeignRes nonIOok isFFIExportResultTy res1_ty
133 checkForeignRes mustBeIO isFFIDynResultTy res_ty
134 checkFEDArgs arg1_tys
136 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
137 other -> addErrTc (illegalForeignTyErr empty sig_ty)
140 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
141 | isDynamicTarget target = do -- Foreign import dynamic
142 checkCg checkCOrAsmOrInterp
144 case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
146 check False (illegalForeignTyErr empty sig_ty)
148 (arg1_ty:arg_tys) -> do
150 check (isFFIDynArgumentTy arg1_ty)
151 (illegalForeignTyErr argument arg1_ty)
152 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
153 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
155 | otherwise = do -- Normal foreign import
156 checkCg (checkCOrAsmOrDotNetOrInterp)
160 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
161 checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
164 -- This makes a convenient place to check
165 -- that the C identifier is valid for C
166 checkCTarget (StaticTarget str) = do
167 checkCg checkCOrAsmOrDotNetOrInterp
168 check (isCLabelString str) (badCName str)
171 On an Alpha, with foreign export dynamic, due to a giant hack when
172 building adjustor thunks, we only allow 4 integer arguments with
173 foreign export dynamic (i.e., 32 bytes of arguments after padding each
174 argument to a quadword, excluding floating-point arguments).
176 The check is needed for both via-C and native-code routes
179 #include "nativeGen/NCG.h"
180 #if alpha_TARGET_ARCH
182 = check (integral_args <= 32) err
184 integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
185 | prim_rep <- map typePrimRep arg_tys,
186 primRepHint prim_rep /= FloatHint ]
187 err = ptext SLIT("On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
189 checkFEDArgs arg_tys = return ()
194 %************************************************************************
198 %************************************************************************
201 tcForeignExports :: [LForeignDecl Name]
202 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
203 tcForeignExports decls
204 = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
206 combine (binds, fs) fe = do
207 (b, f) <- wrapLocSndM tcFExport fe
208 return (b `consBag` binds, f:fs)
210 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
211 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
212 addErrCtxt (foreignDeclCtxt fo) $ do
214 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
215 rhs <- tcPolyExpr (nlHsVar nm) sig_ty
217 tcCheckFEType sig_ty spec
219 -- we're exporting a function, but at a type possibly more
220 -- constrained than its declared/inferred type. Hence the need
221 -- to create a local binding which will call the exported function
222 -- at a particular type (and, maybe, overloading).
227 -- We need to give a name to the new top-level binding that
228 -- is *stable* (i.e. the compiler won't change it later),
229 -- because this name will be referred to by the C code stub.
230 -- Furthermore, the name must be unique (see #1533). If the
231 -- same function is foreign-exported multiple times, the
232 -- top-level bindings generated must not have the same name.
233 -- Hence we create an External name (doesn't change), and we
234 -- append a Unique to the string right here.
235 uniq_str = showSDoc (pprUnique uniq)
236 occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
237 gnm = mkExternalName uniq mod (mkForeignExportOcc occ) loc
238 id = mkExportedLocalId gnm sig_ty
239 bind = L loc (VarBind id rhs)
241 return (bind, ForeignExport (L loc id) undefined spec)
244 ------------ Checking argument types for foreign export ----------------------
247 tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
248 check (isCLabelString str) (badCName str)
249 checkForeignArgs isFFIExternalTy arg_tys
250 checkForeignRes nonIOok isFFIExportResultTy res_ty
252 -- Drop the foralls before inspecting n
253 -- the structure of the foreign type.
254 (_, t_ty) = tcSplitForAllTys sig_ty
255 (arg_tys, res_ty) = tcSplitFunTys t_ty
260 %************************************************************************
262 \subsection{Miscellaneous}
264 %************************************************************************
267 ------------ Checking argument types for foreign import ----------------------
268 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
269 checkForeignArgs pred tys
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")
321 let target = hscTarget dflags
323 HscNothing -> return ()
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 _ = return ()
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")