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