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