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