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 (xopt 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 -- This is a warning, not an error. see #3336
 314 checkCConv StdCallConv  = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
 315 #endif
 316 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
 317 checkCConv CmmCallConv  = panic "checkCConv CmmCallConv"
 318 \end{code}
 319
 320 Deprecated "threadsafe" calls
 321
 322 \begin{code}
 323 checkSafety :: Safety -> TcM ()
 324 checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.")
 325 checkSafety _               = return ()
 326 \end{code}
 327
 328 Warnings
 329
 330 \begin{code}
 331 check :: Bool -> Message -> TcM ()
 332 check True _       = return ()
 333 check _    the_err = addErrTc the_err
 334
 335 illegalForeignTyErr :: SDoc -> Type -> SDoc
 336 illegalForeignTyErr arg_or_res ty
 337   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
 338                 ptext (sLit "type in foreign declaration:")])
 339        2 (hsep [ppr ty])
 340
 341 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 342 argument, result :: SDoc
 343 argument = text "argument"
 344 result   = text "result"
 345
 346 badCName :: CLabelString -> Message
 347 badCName target
 348   = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
 349
 350 foreignDeclCtxt :: ForeignDecl Name -> SDoc
 351 foreignDeclCtxt fo
 352   = hang (ptext (sLit "When checking declaration:"))
 353        2 (ppr fo)
 354 \end{code}