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