782ce3f6dbb07a7af278171fb08ac2a882e702b7
[ghc.git] / compiler / typecheck / TcForeign.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1998
4 %
5 \section[TcForeign]{Typechecking \tr{foreign} declarations}
6
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.
13
14 \begin{code}
15 module TcForeign 
16         ( 
17           tcForeignImports
18         , tcForeignExports
19         ) where
20
21 #include "HsVersions.h"
22
23 import HsSyn
24
25 import TcRnMonad
26 import TcHsType
27 import TcExpr
28 import TcEnv
29
30 import ForeignCall
31 import ErrUtils
32 import Id
33 import Name
34 import TcType
35 import DynFlags
36 import Outputable
37 import SrcLoc
38 import Bag
39 import FastString
40 \end{code}
41
42 \begin{code}
43 -- Defines a binding
44 isForeignImport :: LForeignDecl name -> Bool
45 isForeignImport (L _ (ForeignImport _ _ _)) = True
46 isForeignImport _                             = False
47
48 -- Exports a binding
49 isForeignExport :: LForeignDecl name -> Bool
50 isForeignExport (L _ (ForeignExport _ _ _)) = True
51 isForeignExport _                             = False
52 \end{code}
53
54 %************************************************************************
55 %*                                                                      *
56 \subsection{Imports}
57 %*                                                                      *
58 %************************************************************************
59
60 \begin{code}
61 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
62 tcForeignImports decls
63   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
64
65 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
66 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
67  = addErrCtxt (foreignDeclCtxt fo)  $ 
68    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
69       ; let 
70           -- Drop the foralls before inspecting the
71           -- structure of the foreign type.
72             (_, t_ty)         = tcSplitForAllTys sig_ty
73             (arg_tys, res_ty) = tcSplitFunTys t_ty
74             id                = mkLocalId nm sig_ty
75                 -- Use a LocalId to obey the invariant that locally-defined 
76                 -- things are LocalIds.  However, it does not need zonking,
77                 -- (so TcHsSyn.zonkForeignExports ignores it).
78    
79       ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
80          -- Can't use sig_ty here because sig_ty :: Type and 
81          -- we need HsType Id hence the undefined
82       ; return (id, ForeignImport (L loc id) undefined imp_decl') }
83 tcFImport d = pprPanic "tcFImport" (ppr d)
84 \end{code}
85
86
87 ------------ Checking types for foreign import ----------------------
88 \begin{code}
89 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
90
91 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
92   = ASSERT( null arg_tys )
93     do { checkCg checkCOrAsmOrLlvmOrInterp
94        ; checkSafety safety
95        ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
96        ; return idecl }      -- NB check res_ty not sig_ty!
97                              --    In case sig_ty is (forall a. ForeignPtr a)
98
99 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
100         -- Foreign wrapper (former f.e.d.)
101         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
102         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
103         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
104         -- is DEPRECATED, though.
105     checkCg checkCOrAsmOrLlvmOrInterp
106     checkCConv cconv
107     checkSafety safety
108     case arg_tys of
109         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
110                         checkForeignRes nonIOok  isFFIExportResultTy res1_ty
111                         checkForeignRes mustBeIO isFFIDynResultTy    res_ty
112                   where
113                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
114         _ -> addErrTc (illegalForeignTyErr empty sig_ty)
115     return idecl
116
117 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
118   | isDynamicTarget target = do -- Foreign import dynamic
119       checkCg checkCOrAsmOrLlvmOrInterp
120       checkCConv cconv
121       checkSafety safety
122       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
123         []                -> do
124           check False (illegalForeignTyErr empty sig_ty)
125           return idecl
126         (arg1_ty:arg_tys) -> do
127           dflags <- getDOpts
128           check (isFFIDynArgumentTy arg1_ty)
129                 (illegalForeignTyErr argument arg1_ty)
130           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
131           checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
132           return idecl
133   | cconv == PrimCallConv = do
134       dflags <- getDOpts
135       check (dopt Opt_GHCForeignImportPrim dflags)
136             (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
137       checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
138       checkCTarget target
139       check (playSafe safety)
140             (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
141       checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
142       -- prim import result is more liberal, allows (#,,#)
143       checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty
144       return idecl
145   | otherwise = do              -- Normal foreign import
146       checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
147       checkCConv cconv
148       checkSafety safety
149       checkCTarget target
150       dflags <- getDOpts
151       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
152       checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
153       checkMissingAmpersand dflags arg_tys res_ty
154       return idecl
155
156
157 -- This makes a convenient place to check
158 -- that the C identifier is valid for C
159 checkCTarget :: CCallTarget -> TcM ()
160 checkCTarget (StaticTarget str _) = do
161     checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
162     check (isCLabelString str) (badCName str)
163
164 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
165
166
167 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
168 checkMissingAmpersand dflags arg_tys res_ty
169   | null arg_tys && isFunPtrTy res_ty &&
170     dopt Opt_WarnDodgyForeignImports dflags
171   = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
172   | otherwise
173   = return ()
174 \end{code}
175
176 %************************************************************************
177 %*                                                                      *
178 \subsection{Exports}
179 %*                                                                      *
180 %************************************************************************
181
182 \begin{code}
183 tcForeignExports :: [LForeignDecl Name] 
184                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
185 tcForeignExports decls
186   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
187   where
188    combine (binds, fs) fe = do
189        (b, f) <- wrapLocSndM tcFExport fe
190        return (b `consBag` binds, f:fs)
191
192 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
193 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
194    addErrCtxt (foreignDeclCtxt fo)      $ do
195
196    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
197    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
198
199    tcCheckFEType sig_ty spec
200
201           -- we're exporting a function, but at a type possibly more
202           -- constrained than its declared/inferred type. Hence the need
203           -- to create a local binding which will call the exported function
204           -- at a particular type (and, maybe, overloading).
205
206
207    -- We need to give a name to the new top-level binding that
208    -- is *stable* (i.e. the compiler won't change it later),
209    -- because this name will be referred to by the C code stub.
210    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
211    return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
212 tcFExport d = pprPanic "tcFExport" (ppr d)
213 \end{code}
214
215 ------------ Checking argument types for foreign export ----------------------
216
217 \begin{code}
218 tcCheckFEType :: Type -> ForeignExport -> TcM ()
219 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
220     checkCg checkCOrAsmOrLlvm
221     check (isCLabelString str) (badCName str)
222     checkCConv cconv
223     checkForeignArgs isFFIExternalTy arg_tys
224     checkForeignRes nonIOok isFFIExportResultTy res_ty
225   where
226       -- Drop the foralls before inspecting n
227       -- the structure of the foreign type.
228     (_, t_ty) = tcSplitForAllTys sig_ty
229     (arg_tys, res_ty) = tcSplitFunTys t_ty
230 \end{code}
231
232
233
234 %************************************************************************
235 %*                                                                      *
236 \subsection{Miscellaneous}
237 %*                                                                      *
238 %************************************************************************
239
240 \begin{code}
241 ------------ Checking argument types for foreign import ----------------------
242 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
243 checkForeignArgs pred tys
244   = mapM_ go tys
245   where
246     go ty = check (pred ty) (illegalForeignTyErr argument ty)
247
248 ------------ Checking result types for foreign calls ----------------------
249 -- Check that the type has the form 
250 --    (IO t) or (t) , and that t satisfies the given predicate.
251 --
252 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
253
254 nonIOok, mustBeIO :: Bool
255 nonIOok  = True
256 mustBeIO = False
257
258 checkForeignRes non_io_result_ok pred_res_ty ty
259         -- (IO t) is ok, and so is any newtype wrapping thereof
260   | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
261     pred_res_ty res_ty
262   = return ()
263  
264   | otherwise
265   = check (non_io_result_ok && pred_res_ty ty) 
266           (illegalForeignTyErr result ty)
267 \end{code}
268
269 \begin{code}
270 checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc
271 checkCOrAsmOrLlvm HscC    = Nothing
272 checkCOrAsmOrLlvm HscAsm  = Nothing
273 checkCOrAsmOrLlvm HscLlvm = Nothing
274 checkCOrAsmOrLlvm _
275    = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
276
277 checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
278 checkCOrAsmOrLlvmOrInterp HscC           = Nothing
279 checkCOrAsmOrLlvmOrInterp HscAsm         = Nothing
280 checkCOrAsmOrLlvmOrInterp HscLlvm        = Nothing
281 checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
282 checkCOrAsmOrLlvmOrInterp _
283    = Just (text "requires interpreted, C, Llvm or native code generation")
284
285 checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
286 checkCOrAsmOrLlvmOrDotNetOrInterp HscC           = Nothing
287 checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm         = Nothing
288 checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm        = Nothing
289 checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
290 checkCOrAsmOrLlvmOrDotNetOrInterp _
291    = Just (text "requires interpreted, C, Llvm or native code generation")
292
293 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
294 checkCg check = do
295    dflags <- getDOpts
296    let target = hscTarget dflags
297    case target of
298      HscNothing -> return ()
299      _ ->
300        case check target of
301          Nothing  -> return ()
302          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
303 \end{code}
304                            
305 Calling conventions
306
307 \begin{code}
308 checkCConv :: CCallConv -> TcM ()
309 checkCConv CCallConv  = return ()
310 #if i386_TARGET_ARCH
311 checkCConv StdCallConv = return ()
312 #else
313 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall")
314 #endif
315 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
316 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
317 \end{code}
318
319 Deprecated "threadsafe" calls
320
321 \begin{code}
322 checkSafety :: Safety -> TcM ()
323 checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.")
324 checkSafety _               = return ()
325 \end{code}
326
327 Warnings
328
329 \begin{code}
330 check :: Bool -> Message -> TcM ()
331 check True _       = return ()
332 check _    the_err = addErrTc the_err
333
334 illegalForeignTyErr :: SDoc -> Type -> SDoc
335 illegalForeignTyErr arg_or_res ty
336   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, 
337                 ptext (sLit "type in foreign declaration:")])
338        2 (hsep [ppr ty])
339
340 -- Used for 'arg_or_res' argument to illegalForeignTyErr
341 argument, result :: SDoc
342 argument = text "argument"
343 result   = text "result"
344
345 badCName :: CLabelString -> Message
346 badCName target 
347    = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
348
349 foreignDeclCtxt :: ForeignDecl Name -> SDoc
350 foreignDeclCtxt fo
351   = hang (ptext (sLit "When checking declaration:"))
352        2 (ppr fo)
353 \end{code}
354