Implement a capi calling convention; fixes #2979
[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 import RnEnv
30
31 import FamInst
32 import FamInstEnv
33 import Type
34 import TypeRep
35 import ForeignCall
36 import ErrUtils
37 import Id
38 import Name
39 import RdrName
40 import DataCon
41 import TyCon
42 import TcType
43 import Coercion
44 import PrelNames
45 import DynFlags
46 import Outputable
47 import Platform
48 import SrcLoc
49 import Bag
50 import FastString
51
52 import Control.Monad
53 \end{code}
54
55 \begin{code}
56 -- Defines a binding
57 isForeignImport :: LForeignDecl name -> Bool
58 isForeignImport (L _ (ForeignImport _ _ _ _)) = True
59 isForeignImport _                             = False
60
61 -- Exports a binding
62 isForeignExport :: LForeignDecl name -> Bool
63 isForeignExport (L _ (ForeignExport _ _ _ _)) = True
64 isForeignExport _                             = False
65 \end{code}
66
67 \begin{code}
68 -- normaliseFfiType takes the type from an FFI declaration, and
69 -- evaluates any type synonyms, type functions, and newtypes. However,
70 -- we are only allowed to look through newtypes if the constructor is
71 -- in scope.
72 normaliseFfiType :: Type -> TcM (Coercion, Type)
73 normaliseFfiType ty
74     = do fam_envs <- tcGetFamInstEnvs
75          normaliseFfiType' fam_envs ty
76
77 normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type)
78 normaliseFfiType' env ty0 = go [] ty0
79   where
80     go :: [TyCon] -> Type -> TcM (Coercion, Type)
81     go rec_nts ty | Just ty' <- coreView ty     -- Expand synonyms
82         = go rec_nts ty'
83
84     go rec_nts ty@(TyConApp tc tys)
85         -- We don't want to look through the IO newtype, even if it is
86         -- in scope, so we have a special case for it:
87         | tc `hasKey` ioTyConKey
88         = children_only
89         | isNewTyCon tc         -- Expand newtypes
90         -- We can't just use isRecursiveTyCon here, as we need to allow
91         -- some recursive types as described below
92         = if tc `elem` rec_nts  -- See Note [Expanding newtypes] in Type.lhs
93           then -- If this is a recursive newtype then it will normally
94                -- be rejected later as not being a valid FFI type.
95                -- Sometimes recursion is OK though, e.g. with
96                --     newtype T = T (Ptr T)
97                -- we don't reject the type for being recursive.
98                return (Refl ty, ty)
99           else do newtypeOK <- do env <- getGblEnv
100                                   case tyConSingleDataCon_maybe tc of
101                                       Just dataCon ->
102                                           case lookupGRE_Name (tcg_rdr_env env) $ dataConName dataCon of
103                                               [gre] ->
104                                                   do -- If we look through a newtype constructor, then we need it to be in scope.
105                                                      -- But if this is the only use if that import then we'll get an unused import
106                                                      -- warning, so we need to mark a valid RdrName for it as used.
107                                                      case gre_prov gre of
108                                                          Imported (is : _) ->
109                                                              do let modName = is_as (is_decl is)
110                                                                     occName = nameOccName (dataConName dataCon)
111                                                                     rdrName = mkRdrQual modName occName
112                                                                 addUsedRdrNames [rdrName]
113                                                          Imported [] ->
114                                                              panic "normaliseFfiType': Imported []"
115                                                          LocalDef ->
116                                                              return ()
117                                                      return True
118                                               [] ->
119                                                   return False
120                                               _ ->
121                                                   panic "normaliseFfiType': Got more GREs than expected"
122                                       _ ->
123                                           return False
124                   when (not newtypeOK) $
125                      -- later: stop_here
126                     addWarnTc (ptext (sLit "newtype") <+> quotes (ppr tc) <+>
127                                ptext (sLit "is used in an FFI declaration,") $$
128                                ptext (sLit "but its constructor is not in scope.") $$
129                                ptext (sLit "This will become an error in GHC 7.6.1."))
130
131                   let nt_co = mkAxInstCo (newTyConCo tc) tys
132                   add_co nt_co rec_nts' nt_rhs
133
134         | isFamilyTyCon tc              -- Expand open tycons
135         , (co, ty) <- normaliseTcApp env tc tys
136         , not (isReflCo co)
137         = add_co co rec_nts ty
138
139         | otherwise
140         = return (mkReflCo ty, ty)
141             -- If we have reached an ordinary (non-newtype) type constructor,
142             -- we are done.  Note that we don't need to normalise the arguments,
143             -- because whether an FFI type is legal or not depends only on
144             -- the top-level type constructor (e.g. "Ptr a" is valid for all a).
145         where
146
147           children_only = do xs <- mapM (go rec_nts) tys
148                              let (cos, tys') = unzip xs
149                              return (mkTyConAppCo tc cos, mkTyConApp tc tys')
150           nt_rhs = newTyConInstRhs tc tys
151           rec_nts' | isRecursiveTyCon tc = tc:rec_nts
152                    | otherwise           = rec_nts
153
154     go rec_nts (AppTy ty1 ty2)
155       = do (coi1, nty1) <- go rec_nts ty1
156            (coi2, nty2) <- go rec_nts ty2
157            return (mkAppCo coi1 coi2, mkAppTy nty1 nty2)
158
159     go rec_nts (FunTy ty1 ty2)
160       = do (coi1,nty1) <- go rec_nts ty1
161            (coi2,nty2) <- go rec_nts ty2
162            return (mkFunCo coi1 coi2, mkFunTy nty1 nty2)
163
164     go rec_nts (ForAllTy tyvar ty1)
165       = do (coi,nty1) <- go rec_nts ty1
166            return (mkForAllCo tyvar coi, ForAllTy tyvar nty1)
167
168     go _ ty@(TyVarTy _)
169       = return (Refl ty, ty)
170
171     add_co co rec_nts ty
172         = do (co', ty') <- go rec_nts ty
173              return (mkTransCo co co', ty')
174 \end{code}
175
176 %************************************************************************
177 %*                                                                      *
178 \subsection{Imports}
179 %*                                                                      *
180 %************************************************************************
181
182 \begin{code}
183 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
184 tcForeignImports decls
185   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
186
187 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
188 tcFImport fo@(ForeignImport (L loc nm) hs_ty _ imp_decl)
189   = addErrCtxt (foreignDeclCtxt fo)  $
190     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
191        ; (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty
192        ; let
193            -- Drop the foralls before inspecting the
194            -- structure of the foreign type.
195              (_, t_ty)         = tcSplitForAllTys norm_sig_ty
196              (arg_tys, res_ty) = tcSplitFunTys t_ty
197              id                = mkLocalId nm sig_ty
198                  -- Use a LocalId to obey the invariant that locally-defined
199                  -- things are LocalIds.  However, it does not need zonking,
200                  -- (so TcHsSyn.zonkForeignExports ignores it).
201
202        ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
203           -- Can't use sig_ty here because sig_ty :: Type and
204           -- we need HsType Id hence the undefined
205        ; return (id, ForeignImport (L loc id) undefined (mkSymCo norm_co) imp_decl') }
206 tcFImport d = pprPanic "tcFImport" (ppr d)
207 \end{code}
208
209
210 ------------ Checking types for foreign import ----------------------
211 \begin{code}
212 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
213
214 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _))
215   = ASSERT( null arg_tys )
216     do { checkCg checkCOrAsmOrLlvmOrInterp
217        ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
218        ; return idecl }      -- NB check res_ty not sig_ty!
219                              --    In case sig_ty is (forall a. ForeignPtr a)
220
221 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do
222         -- Foreign wrapper (former f.e.d.)
223         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
224         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
225         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
226         -- is DEPRECATED, though.
227     checkCg checkCOrAsmOrLlvmOrInterp
228     checkCConv cconv
229     case arg_tys of
230         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
231                         checkForeignRes nonIOok  checkSafe isFFIExportResultTy res1_ty
232                         checkForeignRes mustBeIO checkSafe isFFIDynResultTy    res_ty
233                   where
234                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
235         _ -> addErrTc (illegalForeignTyErr empty sig_ty)
236     return idecl
237
238 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
239   | isDynamicTarget target = do -- Foreign import dynamic
240       checkCg checkCOrAsmOrLlvmOrInterp
241       checkCConv cconv
242       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
243         []                -> do
244           check False (illegalForeignTyErr empty sig_ty)
245           return idecl
246         (arg1_ty:arg_tys) -> do
247           dflags <- getDOpts
248           check (isFFIDynArgumentTy arg1_ty)
249                 (illegalForeignTyErr argument arg1_ty)
250           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
251           checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
252           return idecl
253   | cconv == PrimCallConv = do
254       dflags <- getDOpts
255       check (xopt Opt_GHCForeignImportPrim dflags)
256             (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
257       checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
258       checkCTarget target
259       check (playSafe safety)
260             (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
261       checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
262       -- prim import result is more liberal, allows (#,,#)
263       checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
264       return idecl
265   | otherwise = do              -- Normal foreign import
266       checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
267       checkCConv cconv
268       checkCTarget target
269       dflags <- getDOpts
270       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
271       checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
272       checkMissingAmpersand dflags arg_tys res_ty
273       return idecl
274
275
276 -- This makes a convenient place to check
277 -- that the C identifier is valid for C
278 checkCTarget :: CCallTarget -> TcM ()
279 checkCTarget (StaticTarget str _) = do
280     checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
281     check (isCLabelString str) (badCName str)
282
283 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
284
285
286 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
287 checkMissingAmpersand dflags arg_tys res_ty
288   | null arg_tys && isFunPtrTy res_ty &&
289     wopt Opt_WarnDodgyForeignImports dflags
290   = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
291   | otherwise
292   = return ()
293 \end{code}
294
295 %************************************************************************
296 %*                                                                      *
297 \subsection{Exports}
298 %*                                                                      *
299 %************************************************************************
300
301 \begin{code}
302 tcForeignExports :: [LForeignDecl Name]
303                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
304 tcForeignExports decls
305   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
306   where
307    combine (binds, fs) fe = do
308        (b, f) <- wrapLocSndM tcFExport fe
309        return (b `consBag` binds, f:fs)
310
311 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
312 tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec)
313   = addErrCtxt (foreignDeclCtxt fo) $ do
314
315     sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
316     rhs <- tcPolyExpr (nlHsVar nm) sig_ty
317
318     (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty
319
320     tcCheckFEType norm_sig_ty spec
321
322            -- we're exporting a function, but at a type possibly more
323            -- constrained than its declared/inferred type. Hence the need
324            -- to create a local binding which will call the exported function
325            -- at a particular type (and, maybe, overloading).
326
327
328     -- We need to give a name to the new top-level binding that
329     -- is *stable* (i.e. the compiler won't change it later),
330     -- because this name will be referred to by the C code stub.
331     id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
332     return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec)
333 tcFExport d = pprPanic "tcFExport" (ppr d)
334 \end{code}
335
336 ------------ Checking argument types for foreign export ----------------------
337
338 \begin{code}
339 tcCheckFEType :: Type -> ForeignExport -> TcM ()
340 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
341     checkCg checkCOrAsmOrLlvm
342     check (isCLabelString str) (badCName str)
343     checkCConv cconv
344     checkForeignArgs isFFIExternalTy arg_tys
345     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
346   where
347       -- Drop the foralls before inspecting n
348       -- the structure of the foreign type.
349     (_, t_ty) = tcSplitForAllTys sig_ty
350     (arg_tys, res_ty) = tcSplitFunTys t_ty
351 \end{code}
352
353
354
355 %************************************************************************
356 %*                                                                      *
357 \subsection{Miscellaneous}
358 %*                                                                      *
359 %************************************************************************
360
361 \begin{code}
362 ------------ Checking argument types for foreign import ----------------------
363 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
364 checkForeignArgs pred tys = mapM_ go tys
365   where go ty = check (pred ty) (illegalForeignTyErr argument ty)
366
367 ------------ Checking result types for foreign calls ----------------------
368 -- | Check that the type has the form
369 --    (IO t) or (t) , and that t satisfies the given predicate.
370 -- When calling this function, any newtype wrappers (should) have been
371 -- already dealt with by normaliseFfiType.
372 -- 
373 -- We also check that the Safe Haskell condition of FFI imports having
374 -- results in the IO monad holds.
375 --
376 checkForeignRes :: Bool -> Bool -> (Type -> Bool) -> Type -> TcM ()
377 checkForeignRes non_io_result_ok check_safe pred_res_ty ty
378   = case tcSplitIOType_maybe ty of
379         -- Got an IO result type, that's always fine!
380         Just (_, res_ty) | pred_res_ty res_ty -> return ()
381
382         -- Case for non-IO result type with FFI Import
383         _ -> do
384             dflags <- getDOpts
385             case (pred_res_ty ty && non_io_result_ok) of
386                 -- handle normal typecheck fail, we want to handle this first and
387                 -- only report safe haskell errors if the normal type check is OK.
388                 False -> addErrTc $ illegalForeignTyErr result ty
389
390                 -- handle safe infer fail
391                 _ | check_safe && safeInferOn dflags
392                     -> recordUnsafeInfer
393
394                 -- handle safe language typecheck fail
395                 _ | check_safe && safeLanguageOn dflags
396                     -> addErrTc $ illegalForeignTyErr result ty $+$ safeHsErr
397
398                 -- sucess! non-IO return is fine
399                 _ -> return ()
400
401   where 
402     safeHsErr = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad"
403
404 nonIOok, mustBeIO :: Bool
405 nonIOok  = True
406 mustBeIO = False
407
408 checkSafe, noCheckSafe :: Bool
409 checkSafe   = True
410 noCheckSafe = False
411 \end{code}
412
413 Checking a supported backend is in use
414
415 \begin{code}
416 checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc
417 checkCOrAsmOrLlvm HscC    = Nothing
418 checkCOrAsmOrLlvm HscAsm  = Nothing
419 checkCOrAsmOrLlvm HscLlvm = Nothing
420 checkCOrAsmOrLlvm _
421   = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
422
423 checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
424 checkCOrAsmOrLlvmOrInterp HscC           = Nothing
425 checkCOrAsmOrLlvmOrInterp HscAsm         = Nothing
426 checkCOrAsmOrLlvmOrInterp HscLlvm        = Nothing
427 checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
428 checkCOrAsmOrLlvmOrInterp _
429   = Just (text "requires interpreted, C, Llvm or native code generation")
430
431 checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
432 checkCOrAsmOrLlvmOrDotNetOrInterp HscC           = Nothing
433 checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm         = Nothing
434 checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm        = Nothing
435 checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
436 checkCOrAsmOrLlvmOrDotNetOrInterp _
437   = Just (text "requires interpreted, C, Llvm or native code generation")
438
439 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
440 checkCg check = do
441     dflags <- getDOpts
442     let target = hscTarget dflags
443     case target of
444       HscNothing -> return ()
445       _ ->
446         case check target of
447           Nothing  -> return ()
448           Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
449 \end{code}
450
451 Calling conventions
452
453 \begin{code}
454 checkCConv :: CCallConv -> TcM ()
455 checkCConv CCallConv    = return ()
456 checkCConv CApiConv     = return ()
457 checkCConv StdCallConv  = do dflags <- getDOpts
458                              let platform = targetPlatform dflags
459                              unless (platformArch platform == ArchX86) $
460                                  -- This is a warning, not an error. see #3336
461                                  addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
462 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
463 checkCConv CmmCallConv  = panic "checkCConv CmmCallConv"
464 \end{code}
465
466 Warnings
467
468 \begin{code}
469 check :: Bool -> Message -> TcM ()
470 check True _       = return ()
471 check _    the_err = addErrTc the_err
472
473 illegalForeignTyErr :: SDoc -> Type -> SDoc
474 illegalForeignTyErr arg_or_res ty
475   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
476                 ptext (sLit "type in foreign declaration:")])
477        2 (hsep [ppr ty])
478
479 -- Used for 'arg_or_res' argument to illegalForeignTyErr
480 argument, result :: SDoc
481 argument = text "argument"
482 result   = text "result"
483
484 badCName :: CLabelString -> Message
485 badCName target
486   = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
487
488 foreignDeclCtxt :: ForeignDecl Name -> SDoc
489 foreignDeclCtxt fo
490   = hang (ptext (sLit "When checking declaration:"))
491        2 (ppr fo)
492 \end{code}