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