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