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