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