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