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