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(..), FoImport(..), FoExport(..)
  24                         )
  25 import RnHsSyn          ( RenamedHsDecl, RenamedForeignDecl )
  26
  27 import TcMonad
  28 import TcEnv            ( newLocalId )
  29 import TcMonoType       ( tcHsLiftedSigType )
  30 import TcHsSyn          ( TcMonoBinds, TypecheckedForeignDecl,
  31                           TcForeignExportDecl )
  32 import TcExpr           ( tcPolyExpr )
  33 import Inst             ( emptyLIE, LIE, plusLIE )
  34
  35 import ErrUtils         ( Message )
  36 import Id               ( Id, mkLocalId )
  37 import Name             ( nameOccName )
  38 import Type             ( splitFunTys
  39                         , splitTyConApp_maybe
  40                         , splitForAllTys
  41                         )
  42 import TysWiredIn       ( isFFIArgumentTy, isFFIImportResultTy,
  43                           isFFIExportResultTy,
  44                           isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
  45                           isFFILabelTy
  46                         )
  47 import Type             ( Type )
  48 import ForeignCall      ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget )
  49 import CStrings         ( CLabelString, isCLabelString )
  50 import PrelNames        ( hasKey, ioTyConKey )
  51 import CmdLineOpts      ( dopt_HscLang, HscLang(..) )
  52 import Outputable
  53
  54 \end{code}
  55
  56 \begin{code}
  57 -- Defines a binding
  58 isForeignImport :: ForeignDecl name -> Bool
  59 isForeignImport (ForeignImport _ _ _ _) = True
  60 isForeignImport _                       = False
  61
  62 -- Exports a binding
  63 isForeignExport :: ForeignDecl name -> Bool
  64 isForeignExport (ForeignExport _ _ _ _) = True
  65 isForeignExport _                       = False
  66 \end{code}
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection{Imports}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 \begin{code}
  75 tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
  76 tcForeignImports decls =
  77    mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
  78
  79 tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
  80 tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc)
  81  = tcAddSrcLoc src_loc                  $
  82    tcAddErrCtxt (foreignDeclCtxt fo)    $
  83    tcHsLiftedSigType hs_ty              `thenTc`        \ sig_ty ->
  84    let
  85       -- drop the foralls before inspecting the structure
  86       -- of the foreign type.
  87         (_, t_ty)         = splitForAllTys sig_ty
  88         (arg_tys, res_ty) = splitFunTys t_ty
  89         id                = mkLocalId nm sig_ty
  90    in
  91    tcCheckFIType sig_ty arg_tys res_ty imp_decl         `thenNF_Tc_`
  92    returnTc (id, ForeignImport id undefined imp_decl src_loc)
  93 \end{code}
  94
  95
  96 ------------ Checking types for foreign import ----------------------
  97 \begin{code}
  98 tcCheckFIType _ _ _ (DNImport _)
  99   = checkCg checkDotNet
 100
 101 tcCheckFIType sig_ty arg_tys res_ty (LblImport _)
 102   = checkCg checkCOrAsm         `thenNF_Tc_`
 103     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
 104
 105 tcCheckFIType sig_ty arg_tys res_ty (CDynImport _)
 106   =     -- Foreign export dynamic
 107         -- The first (and only!) arg has got to be a function type
 108         -- and it must return IO t; result type is IO Addr
 109     checkCg checkCOrAsm         `thenNF_Tc_`
 110     case arg_tys of
 111         [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys                  `thenNF_Tc_`
 112                      checkForeignRes nonIOok  isFFIExportResultTy res1_ty       `thenNF_Tc_`
 113                      checkForeignRes mustBeIO isFFIDynResultTy    res_ty
 114                   where
 115                      (arg1_tys, res1_ty) = splitFunTys arg1_ty
 116         other -> addErrTc (illegalForeignTyErr empty sig_ty)
 117
 118 tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
 119   | isDynamicTarget target      -- Foreign import dynamic
 120   = checkCg checkCOrAsm         `thenNF_Tc_`
 121     case arg_tys of             -- The first arg must be Addr
 122       []                -> check False (illegalForeignTyErr empty sig_ty)
 123       (arg1_ty:arg_tys) -> getDOptsTc                                                   `thenNF_Tc` \ dflags ->
 124                            check (isFFIDynArgumentTy arg1_ty)
 125                                  (illegalForeignTyErr argument arg1_ty)                 `thenNF_Tc_`
 126                            checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys     `thenNF_Tc_`
 127                            checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 128
 129   | otherwise           -- Normal foreign import
 130   = checkCg (if isCasmTarget target
 131              then checkC else checkCOrAsmOrDotNet)                      `thenNF_Tc_`
 132     checkCTarget target                                         `thenNF_Tc_`
 133     getDOptsTc                                                  `thenNF_Tc` \ dflags ->
 134     checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys    `thenNF_Tc_`
 135     checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 136
 137 -- This makes a convenient place to check
 138 -- that the C identifier is valid for C
 139 checkCTarget (StaticTarget str)
 140   = checkCg checkCOrAsmOrDotNet         `thenNF_Tc_`
 141     check (isCLabelString str) (badCName str)
 142
 143 checkCTarget (CasmTarget _)
 144   = checkCg checkC
 145 \end{code}
 146
 147
 148 %************************************************************************
 149 %*                                                                      *
 150 \subsection{Exports}
 151 %*                                                                      *
 152 %************************************************************************
 153
 154 \begin{code}
 155 tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
 156 tcForeignExports decls =
 157    foldlTc combine (emptyLIE, EmptyMonoBinds, [])
 158                    [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
 159   where
 160    combine (lie, binds, fs) fe =
 161        tcFExport fe `thenTc ` \ (a_lie, b, f) ->
 162        returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
 163
 164 tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
 165 tcFExport fo@(ForeignExport nm hs_ty spec src_loc) =
 166    tcAddSrcLoc src_loc                  $
 167    tcAddErrCtxt (foreignDeclCtxt fo)    $
 168
 169    tcHsLiftedSigType hs_ty             `thenTc` \ sig_ty ->
 170    tcPolyExpr (HsVar nm) sig_ty         `thenTc`    \ (rhs, lie, _, _, _) ->
 171
 172    tcCheckFEType sig_ty spec            `thenTc_`
 173
 174           -- we're exporting a function, but at a type possibly more constrained
 175           -- than its declared/inferred type. Hence the need
 176           -- to create a local binding which will call the exported function
 177           -- at a particular type (and, maybe, overloading).
 178    newLocalId (nameOccName nm) sig_ty src_loc   `thenNF_Tc` \ id ->
 179    let
 180         bind  = VarMonoBind id rhs
 181    in
 182    returnTc (lie, bind, ForeignExport id undefined spec src_loc)
 183 \end{code}
 184
 185 ------------ Checking argument types for foreign export ----------------------
 186
 187 \begin{code}
 188 tcCheckFEType sig_ty (CExport (CExportStatic str _))
 189   = check (isCLabelString str) (badCName str)           `thenNF_Tc_`
 190     checkForeignArgs isFFIExternalTy arg_tys            `thenNF_Tc_`
 191     checkForeignRes nonIOok isFFIExportResultTy res_ty
 192   where
 193       -- Drop the foralls before inspecting n
 194       -- the structure of the foreign type.
 195     (_, t_ty) = splitForAllTys sig_ty
 196     (arg_tys, res_ty) = splitFunTys t_ty
 197 \end{code}
 198
 199
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsection{Miscellaneous}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207 \begin{code}
 208 ------------ Checking argument types for foreign import ----------------------
 209 checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM ()
 210 checkForeignArgs pred tys
 211   = mapNF_Tc go tys     `thenNF_Tc_` returnNF_Tc ()
 212   where
 213     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 214
 215
 216 ------------ Checking result types for foreign calls ----------------------
 217 -- Check that the type has the form
 218 --    (IO t) or (t) , and that t satisfies the given predicate.
 219 --
 220 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM ()
 221
 222 nonIOok  = True
 223 mustBeIO = False
 224
 225 checkForeignRes non_io_result_ok pred_res_ty ty =
 226  case (splitTyConApp_maybe ty) of
 227     Just (io, [res_ty])
 228         | io `hasKey` ioTyConKey && pred_res_ty res_ty
 229         -> returnNF_Tc ()
 230     _
 231         -> check (non_io_result_ok && pred_res_ty ty)
 232                  (illegalForeignTyErr result ty)
 233 \end{code}
 234
 235 \begin{code}
 236 checkDotNet HscILX = Nothing
 237 checkDotNet other  = Just (text "requires .NET code generation (-filx)")
 238
 239 checkC HscC  = Nothing
 240 checkC other = Just (text "requires C code generation (-fvia-C)")
 241
 242 checkCOrAsm HscC   = Nothing
 243 checkCOrAsm HscAsm = Nothing
 244 checkCOrAsm other  = Just (text "via-C or native code generation (-fvia-C)")
 245
 246 checkCOrAsmOrDotNet HscC   = Nothing
 247 checkCOrAsmOrDotNet HscAsm = Nothing
 248 checkCOrAsmOrDotNet HscILX = Nothing
 249 checkCOrAsmOrDotNet other  = Just (text "requires C, native or .NET ILX code generation")
 250
 251 checkCg check
 252  = getDOptsTc           `thenNF_Tc` \ dflags ->
 253    case check (dopt_HscLang dflags) of
 254         Nothing  -> returnNF_Tc ()
 255         Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 256 \end{code}
 257
 258 Warnings
 259
 260 \begin{code}
 261 check :: Bool -> Message -> NF_TcM ()
 262 check True _       = returnTc ()
 263 check _    the_err = addErrTc the_err
 264
 265 illegalForeignTyErr arg_or_res ty
 266   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
 267          4 (hsep [ppr ty])
 268
 269 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 270 argument = text "argument"
 271 result   = text "result"
 272
 273 badCName :: CLabelString -> Message
 274 badCName target = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
 275
 276 foreignDeclCtxt fo
 277   = hang (ptext SLIT("When checking declaration:"))
 278      4   (ppr fo)
 279 \end{code}