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