ghc/compiler/typecheck/TcForeign.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1998
   3 %
   4 \section[TcForeign]{Typechecking \tr{foreign} declarations}
   5
   6 A foreign declaration is used to either give an externally
   7 implemented function a Haskell type (and calling interface) or
   8 give a Haskell function an external calling interface. Either way,
   9 the range of argument and result types these functions can accommodate
  10 is restricted to what the outside world understands (read C), and this
  11 module checks to see if a foreign declaration has got a legal type.
  12
  13 \begin{code}
  14 module TcForeign
  15         (
  16           tcForeignImports
  17         , tcForeignExports
  18         ) where
  19
  20 #include "HsVersions.h"
  21
  22 import HsSyn            ( HsDecl(..), ForeignDecl(..), HsExpr(..),
  23                           MonoBinds(..), ForeignImport(..), ForeignExport(..),
  24                           CImportSpec(..)
  25                         )
  26 import RnHsSyn          ( RenamedHsDecl, RenamedForeignDecl )
  27
  28 import TcMonad
  29 import TcMonoType       ( tcHsSigType, UserTypeCtxt(..) )
  30 import TcHsSyn          ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl )
  31 import TcExpr           ( tcExpr )
  32 import Inst             ( emptyLIE, LIE, plusLIE )
  33
  34 import ErrUtils         ( Message )
  35 import Id               ( Id, mkLocalId, setIdLocalExported )
  36 import PrimRep          ( getPrimRepSize, isFloatingRep )
  37 import Module           ( Module )
  38 import Type             ( typePrimRep )
  39 import OccName          ( mkForeignExportOcc )
  40 import Name             ( NamedThing(..), mkExternalName )
  41 import TcType           ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
  42                           tcSplitForAllTys,
  43                           isFFIArgumentTy, isFFIImportResultTy,
  44                           isFFIExportResultTy, isFFILabelTy,
  45                           isFFIExternalTy, isFFIDynArgumentTy,
  46                           isFFIDynResultTy, isForeignPtrTy
  47                         )
  48 import ForeignCall      ( CExportSpec(..), CCallTarget(..),
  49                           isDynamicTarget, isCasmTarget )
  50 import CStrings         ( CLabelString, isCLabelString )
  51 import PrelNames        ( hasKey, ioTyConKey )
  52 import CmdLineOpts      ( dopt_HscLang, HscLang(..) )
  53 import Outputable
  54
  55 \end{code}
  56
  57 \begin{code}
  58 -- Defines a binding
  59 isForeignImport :: ForeignDecl name -> Bool
  60 isForeignImport (ForeignImport _ _ _ _ _) = True
  61 isForeignImport _                         = False
  62
  63 -- Exports a binding
  64 isForeignExport :: ForeignDecl name -> Bool
  65 isForeignExport (ForeignExport _ _ _ _ _) = True
  66 isForeignExport _                         = False
  67 \end{code}
  68
  69 %************************************************************************
  70 %*                                                                      *
  71 \subsection{Imports}
  72 %*                                                                      *
  73 %************************************************************************
  74
  75 \begin{code}
  76 tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
  77 tcForeignImports decls =
  78   mapAndUnzipTc tcFImport
  79     [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
  80
  81 tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
  82 tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc)
  83  = tcAddSrcLoc src_loc                  $
  84    tcAddErrCtxt (foreignDeclCtxt fo)    $
  85    tcHsSigType (ForSigCtxt nm) hs_ty    `thenTc`        \ sig_ty ->
  86    let
  87       -- drop the foralls before inspecting the structure
  88       -- of the foreign type.
  89         (_, t_ty)         = tcSplitForAllTys sig_ty
  90         (arg_tys, res_ty) = tcSplitFunTys t_ty
  91         id                = mkLocalId nm sig_ty
  92    in
  93    tcCheckFIType sig_ty arg_tys res_ty imp_decl         `thenNF_Tc_`
  94    -- can't use sig_ty here because it :: Type and we need HsType Id
  95    -- hence the undefined
  96    returnTc (id, ForeignImport id undefined imp_decl isDeprec src_loc)
  97 \end{code}
  98
  99
 100 ------------ Checking types for foreign import ----------------------
 101 \begin{code}
 102 tcCheckFIType _ _ _ (DNImport _)
 103   = checkCg checkDotNet
 104
 105 tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ (CLabel _))
 106   = checkCg checkCOrAsm         `thenNF_Tc_`
 107     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
 108
 109 tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ CWrapper)
 110   =     -- Foreign wrapper (former f.e.d.)
 111         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
 112         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
 113         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
 114         -- is DEPRECATED, though.
 115     checkCg checkCOrAsmOrInterp         `thenNF_Tc_`
 116     case arg_tys of
 117         [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys                  `thenNF_Tc_`
 118                      checkForeignRes nonIOok  isFFIExportResultTy res1_ty       `thenNF_Tc_`
 119                      checkForeignRes mustBeIO isFFIDynResultTy    res_ty        `thenNF_Tc_`
 120                      checkFEDArgs arg1_tys
 121                   where
 122                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
 123         other -> addErrTc (illegalForeignTyErr empty sig_ty)
 124
 125 tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target))
 126   | isDynamicTarget target      -- Foreign import dynamic
 127   = checkCg checkCOrAsmOrInterp         `thenNF_Tc_`
 128     case arg_tys of             -- The first arg must be Ptr, FunPtr, or Addr
 129       []                -> check False (illegalForeignTyErr empty sig_ty)
 130       (arg1_ty:arg_tys) -> getDOptsTc                                                   `thenNF_Tc` \ dflags ->
 131                            check (isFFIDynArgumentTy arg1_ty)
 132                                  (illegalForeignTyErr argument arg1_ty)                 `thenNF_Tc_`
 133                            checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys     `thenNF_Tc_`
 134                            checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 135
 136   | otherwise           -- Normal foreign import
 137   = checkCg (if isCasmTarget target
 138              then checkC else checkCOrAsmOrDotNetOrInterp)      `thenNF_Tc_`
 139     checkCTarget target                                         `thenNF_Tc_`
 140     getDOptsTc                                                  `thenNF_Tc` \ dflags ->
 141     checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys    `thenNF_Tc_`
 142     checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 143
 144 -- This makes a convenient place to check
 145 -- that the C identifier is valid for C
 146 checkCTarget (StaticTarget str)
 147   = checkCg checkCOrAsmOrDotNetOrInterp         `thenNF_Tc_`
 148     check (isCLabelString str) (badCName str)
 149
 150 checkCTarget (CasmTarget _)
 151   = checkCg checkC
 152 \end{code}
 153
 154 On an Alpha, with foreign export dynamic, due to a giant hack when
 155 building adjustor thunks, we only allow 4 integer arguments with
 156 foreign export dynamic (i.e., 32 bytes of arguments after padding each
 157 argument to a quadword, excluding floating-point arguments).
 158
 159 The check is needed for both via-C and native-code routes
 160
 161 \begin{code}
 162 #include "nativeGen/NCG.h"
 163 #if alpha_TARGET_ARCH
 164 checkFEDArgs arg_tys
 165   = check (integral_args <= 4) err
 166   where
 167     integral_args = sum (map getPrimRepSize $
 168                          filter (not . isFloatingRep) $
 169                          map typePrimRep arg_tys)
 170     err = ptext SLIT("On Alpha, I can only handle 4 non-floating-point arguments to foreign export dynamic")
 171 #else
 172 checkFEDArgs arg_tys = returnNF_Tc ()
 173 #endif
 174 \end{code}
 175
 176
 177 %************************************************************************
 178 %*                                                                      *
 179 \subsection{Exports}
 180 %*                                                                      *
 181 %************************************************************************
 182
 183 \begin{code}
 184 tcForeignExports :: Module -> [RenamedHsDecl]
 185                  -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
 186 tcForeignExports mod decls =
 187    foldlTc combine (emptyLIE, EmptyMonoBinds, [])
 188      [foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
 189   where
 190    combine (lie, binds, fs) fe =
 191        tcFExport mod fe `thenTc ` \ (a_lie, b, f) ->
 192        returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
 193
 194 tcFExport :: Module -> RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
 195 tcFExport mod fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
 196    tcAddSrcLoc src_loc                  $
 197    tcAddErrCtxt (foreignDeclCtxt fo)    $
 198
 199    tcHsSigType (ForSigCtxt nm) hs_ty    `thenTc` \ sig_ty ->
 200    tcExpr (HsVar nm) sig_ty             `thenTc` \ (rhs, lie) ->
 201
 202    tcCheckFEType sig_ty spec            `thenTc_`
 203
 204           -- we're exporting a function, but at a type possibly more
 205           -- constrained than its declared/inferred type. Hence the need
 206           -- to create a local binding which will call the exported function
 207           -- at a particular type (and, maybe, overloading).
 208
 209    tcGetUnique                          `thenNF_Tc` \ uniq ->
 210    let
 211         gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc
 212         id   = setIdLocalExported (mkLocalId gnm sig_ty)
 213         bind = VarMonoBind id rhs
 214    in
 215    returnTc (lie, bind, ForeignExport id undefined spec isDeprec src_loc)
 216 \end{code}
 217
 218 ------------ Checking argument types for foreign export ----------------------
 219
 220 \begin{code}
 221 tcCheckFEType sig_ty (CExport (CExportStatic str _))
 222   = check (isCLabelString str) (badCName str)           `thenNF_Tc_`
 223     checkForeignArgs isFFIExternalTy arg_tys            `thenNF_Tc_`
 224     checkForeignRes nonIOok isFFIExportResultTy res_ty
 225   where
 226       -- Drop the foralls before inspecting n
 227       -- the structure of the foreign type.
 228     (_, t_ty) = tcSplitForAllTys sig_ty
 229     (arg_tys, res_ty) = tcSplitFunTys t_ty
 230 \end{code}
 231
 232
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 \subsection{Miscellaneous}
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 \begin{code}
 241 ------------ Checking argument types for foreign import ----------------------
 242 checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM ()
 243 checkForeignArgs pred tys
 244   = mapNF_Tc go tys             `thenNF_Tc_`
 245     returnNF_Tc ()
 246   where
 247     go ty = check (pred ty) (illegalForeignTyErr argument ty)   `thenNF_Tc_`
 248             warnTc (isForeignPtrTy ty) foreignPtrWarn
 249     --
 250     foreignPtrWarn =
 251       text "`ForeignPtr' as argument type in a foreign import is deprecated"
 252
 253 ------------ Checking result types for foreign calls ----------------------
 254 -- Check that the type has the form
 255 --    (IO t) or (t) , and that t satisfies the given predicate.
 256 --
 257 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM ()
 258
 259 nonIOok  = True
 260 mustBeIO = False
 261
 262 checkForeignRes non_io_result_ok pred_res_ty ty
 263  = case tcSplitTyConApp_maybe ty of
 264       Just (io, [res_ty])
 265         | io `hasKey` ioTyConKey && pred_res_ty res_ty
 266         -> returnNF_Tc ()
 267       _
 268         -> check (non_io_result_ok && pred_res_ty ty)
 269                  (illegalForeignTyErr result ty)
 270 \end{code}
 271
 272 \begin{code}
 273 checkDotNet HscILX = Nothing
 274 checkDotNet other  = Just (text "requires .NET code generation (-filx)")
 275
 276 checkC HscC  = Nothing
 277 checkC other = Just (text "requires C code generation (-fvia-C)")
 278
 279 checkCOrAsm HscC   = Nothing
 280 checkCOrAsm HscAsm = Nothing
 281 checkCOrAsm other
 282    = Just (text "requires via-C or native code generation (-fvia-C)")
 283
 284 checkCOrAsmOrInterp HscC           = Nothing
 285 checkCOrAsmOrInterp HscAsm         = Nothing
 286 checkCOrAsmOrInterp HscInterpreted = Nothing
 287 checkCOrAsmOrInterp other
 288    = Just (text "requires interpreted, C or native code generation")
 289
 290 checkCOrAsmOrDotNet HscC   = Nothing
 291 checkCOrAsmOrDotNet HscAsm = Nothing
 292 checkCOrAsmOrDotNet HscILX = Nothing
 293 checkCOrAsmOrDotNet other
 294    = Just (text "requires C, native or .NET ILX code generation")
 295
 296 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 297 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
 298 checkCOrAsmOrDotNetOrInterp HscILX         = Nothing
 299 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 300 checkCOrAsmOrDotNetOrInterp other
 301    = Just (text "requires interpreted, C, native or .NET ILX code generation")
 302
 303 checkCg check
 304  = getDOptsTc           `thenNF_Tc` \ dflags ->
 305    let hscLang = dopt_HscLang dflags in
 306    case hscLang of
 307      HscNothing -> returnNF_Tc ()
 308      otherwise  ->
 309        case check hscLang of
 310          Nothing  -> returnNF_Tc ()
 311          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 312 \end{code}
 313
 314 Warnings
 315
 316 \begin{code}
 317 check :: Bool -> Message -> NF_TcM ()
 318 check True _       = returnTc ()
 319 check _    the_err = addErrTc the_err
 320
 321 illegalForeignTyErr arg_or_res ty
 322   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
 323                 ptext SLIT("type in foreign declaration:")])
 324          4 (hsep [ppr ty])
 325
 326 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 327 argument = text "argument"
 328 result   = text "result"
 329
 330 badCName :: CLabelString -> Message
 331 badCName target
 332    = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
 333
 334 foreignDeclCtxt fo
 335   = hang (ptext SLIT("When checking declaration:"))
 336          4 (ppr fo)
 337 \end{code}
 338