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