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