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