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