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            ( ForeignDecl(..), HsExpr(..),
  23                           MonoBinds(..), ForeignImport(..), ForeignExport(..),
  24                           CImportSpec(..)
  25                         )
  26 import RnHsSyn          ( RenamedForeignDecl )
  27
  28 import TcRnMonad
  29 import TcMonoType       ( tcHsSigType, UserTypeCtxt(..) )
  30 import TcHsSyn          ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl )
  31 import TcExpr           ( tcExpr )
  32
  33 import ErrUtils         ( Message )
  34 import Id               ( Id, mkLocalId, mkVanillaGlobal, setIdLocalExported )
  35 import IdInfo           ( noCafIdInfo )
  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,
  46                         )
  47 import ForeignCall      ( CExportSpec(..), CCallTarget(..), CCallConv(..),
  48                           isDynamicTarget, isCasmTarget )
  49 import CStrings         ( CLabelString, isCLabelString )
  50 import PrelNames        ( hasKey, ioTyConKey )
  51 import CmdLineOpts      ( dopt_HscLang, HscLang(..) )
  52 import Outputable
  53
  54 \end{code}
  55
  56 \begin{code}
  57 -- Defines a binding
  58 isForeignImport :: ForeignDecl name -> Bool
  59 isForeignImport (ForeignImport _ _ _ _ _) = True
  60 isForeignImport _                         = False
  61
  62 -- Exports a binding
  63 isForeignExport :: ForeignDecl name -> Bool
  64 isForeignExport (ForeignExport _ _ _ _ _) = True
  65 isForeignExport _                         = False
  66 \end{code}
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection{Imports}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 \begin{code}
  75 tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl])
  76 tcForeignImports decls
  77   = mapAndUnzipM tcFImport (filter isForeignImport decls)
  78
  79 tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
  80 tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc)
  81  = addSrcLoc src_loc                    $
  82    addErrCtxt (foreignDeclCtxt fo)      $
  83    tcHsSigType (ForSigCtxt nm) hs_ty    `thenM` \ 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                = mkVanillaGlobal nm sig_ty noCafIdInfo
  90                 -- Foreign-imported things don't neeed zonking etc
  91                 -- They are rather like constructors; we make the final
  92                 -- Global Id right away.
  93    in
  94    tcCheckFIType sig_ty arg_tys res_ty imp_decl         `thenM_`
  95    -- can't use sig_ty here because it :: Type and we need HsType Id
  96    -- hence the undefined
  97    returnM (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         `thenM_`
 108     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
 109
 110 tcCheckFIType sig_ty arg_tys res_ty (CImport cconv _ _ _ 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 (if cconv == StdCallConv
 117                 then checkC
 118                 else checkCOrAsmOrInterp)               `thenM_`
 119         -- the native code gen can't handle foreign import stdcall "wrapper",
 120         -- because it doesn't emit the '@n' suffix on the label of the
 121         -- C stub function.  Infrastructure changes are required to make this
 122         -- happen; MachLabel will need to carry around information about
 123         -- the arity of the foreign call.
 124     case arg_tys of
 125         [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys                  `thenM_`
 126                      checkForeignRes nonIOok  isFFIExportResultTy res1_ty       `thenM_`
 127                      checkForeignRes mustBeIO isFFIDynResultTy    res_ty        `thenM_`
 128                      checkFEDArgs arg1_tys
 129                   where
 130                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
 131         other -> addErrTc (illegalForeignTyErr empty sig_ty)
 132
 133 tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target))
 134   | isDynamicTarget target      -- Foreign import dynamic
 135   = checkCg checkCOrAsmOrInterp         `thenM_`
 136     case arg_tys of             -- The first arg must be Ptr, FunPtr, or Addr
 137       []                -> check False (illegalForeignTyErr empty sig_ty)
 138       (arg1_ty:arg_tys) -> getDOpts                                                     `thenM` \ dflags ->
 139                            check (isFFIDynArgumentTy arg1_ty)
 140                                  (illegalForeignTyErr argument arg1_ty)                 `thenM_`
 141                            checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys     `thenM_`
 142                            checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 143
 144   | otherwise           -- Normal foreign import
 145   = checkCg (if isCasmTarget target
 146              then checkC else checkCOrAsmOrDotNetOrInterp)      `thenM_`
 147     checkCTarget target                                         `thenM_`
 148     getDOpts                                                    `thenM` \ dflags ->
 149     checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys    `thenM_`
 150     checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 151
 152 -- This makes a convenient place to check
 153 -- that the C identifier is valid for C
 154 checkCTarget (StaticTarget str)
 155   = checkCg checkCOrAsmOrDotNetOrInterp         `thenM_`
 156     check (isCLabelString str) (badCName str)
 157
 158 checkCTarget (CasmTarget _)
 159   = checkCg checkC
 160 \end{code}
 161
 162 On an Alpha, with foreign export dynamic, due to a giant hack when
 163 building adjustor thunks, we only allow 4 integer arguments with
 164 foreign export dynamic (i.e., 32 bytes of arguments after padding each
 165 argument to a quadword, excluding floating-point arguments).
 166
 167 The check is needed for both via-C and native-code routes
 168
 169 \begin{code}
 170 #include "nativeGen/NCG.h"
 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 = returnM ()
 181 #endif
 182 \end{code}
 183
 184
 185 %************************************************************************
 186 %*                                                                      *
 187 \subsection{Exports}
 188 %*                                                                      *
 189 %************************************************************************
 190
 191 \begin{code}
 192 tcForeignExports :: [ForeignDecl Name]
 193                  -> TcM (TcMonoBinds, [TcForeignDecl])
 194 tcForeignExports decls
 195   = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls)
 196   where
 197    combine (binds, fs) fe =
 198        tcFExport fe     `thenM ` \ (b, f) ->
 199        returnM (b `AndMonoBinds` binds, f:fs)
 200
 201 tcFExport :: RenamedForeignDecl -> TcM (TcMonoBinds, TcForeignDecl)
 202 tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
 203    addSrcLoc src_loc                    $
 204    addErrCtxt (foreignDeclCtxt fo)      $
 205
 206    tcHsSigType (ForSigCtxt nm) hs_ty    `thenM` \ sig_ty ->
 207    tcExpr (HsVar nm) sig_ty             `thenM` \ rhs ->
 208
 209    tcCheckFEType sig_ty spec            `thenM_`
 210
 211           -- we're exporting a function, but at a type possibly more
 212           -- constrained than its declared/inferred type. Hence the need
 213           -- to create a local binding which will call the exported function
 214           -- at a particular type (and, maybe, overloading).
 215
 216    newUnique                    `thenM` \ uniq ->
 217    getModule                    `thenM` \ mod ->
 218    let
 219         gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc
 220         id   = setIdLocalExported (mkLocalId gnm sig_ty)
 221         bind = VarMonoBind id rhs
 222    in
 223    returnM (bind, ForeignExport id undefined spec isDeprec src_loc)
 224 \end{code}
 225
 226 ------------ Checking argument types for foreign export ----------------------
 227
 228 \begin{code}
 229 tcCheckFEType sig_ty (CExport (CExportStatic str _))
 230   = check (isCLabelString str) (badCName str)           `thenM_`
 231     checkForeignArgs isFFIExternalTy arg_tys            `thenM_`
 232     checkForeignRes nonIOok isFFIExportResultTy res_ty
 233   where
 234       -- Drop the foralls before inspecting n
 235       -- the structure of the foreign type.
 236     (_, t_ty) = tcSplitForAllTys sig_ty
 237     (arg_tys, res_ty) = tcSplitFunTys t_ty
 238 \end{code}
 239
 240
 241
 242 %************************************************************************
 243 %*                                                                      *
 244 \subsection{Miscellaneous}
 245 %*                                                                      *
 246 %************************************************************************
 247
 248 \begin{code}
 249 ------------ Checking argument types for foreign import ----------------------
 250 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
 251 checkForeignArgs pred tys
 252   = mappM go tys                `thenM_`
 253     returnM ()
 254   where
 255     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 256
 257 ------------ Checking result types for foreign calls ----------------------
 258 -- Check that the type has the form
 259 --    (IO t) or (t) , and that t satisfies the given predicate.
 260 --
 261 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
 262
 263 nonIOok  = True
 264 mustBeIO = False
 265
 266 checkForeignRes non_io_result_ok pred_res_ty ty
 267  = case tcSplitTyConApp_maybe ty of
 268       Just (io, [res_ty])
 269         | io `hasKey` ioTyConKey && pred_res_ty res_ty
 270         -> returnM ()
 271       _
 272         -> check (non_io_result_ok && pred_res_ty ty)
 273                  (illegalForeignTyErr result ty)
 274 \end{code}
 275
 276 \begin{code}
 277 checkDotNet HscILX = Nothing
 278 checkDotNet other  = Just (text "requires .NET code generation (-filx)")
 279
 280 checkC HscC  = Nothing
 281 checkC other = Just (text "requires C code generation (-fvia-C)")
 282
 283 checkCOrAsm HscC   = Nothing
 284 checkCOrAsm HscAsm = Nothing
 285 checkCOrAsm other
 286    = Just (text "requires via-C or native code generation (-fvia-C)")
 287
 288 checkCOrAsmOrInterp HscC           = Nothing
 289 checkCOrAsmOrInterp HscAsm         = Nothing
 290 checkCOrAsmOrInterp HscInterpreted = Nothing
 291 checkCOrAsmOrInterp other
 292    = Just (text "requires interpreted, C or native code generation")
 293
 294 checkCOrAsmOrDotNet HscC   = Nothing
 295 checkCOrAsmOrDotNet HscAsm = Nothing
 296 checkCOrAsmOrDotNet HscILX = Nothing
 297 checkCOrAsmOrDotNet other
 298    = Just (text "requires C, native or .NET ILX code generation")
 299
 300 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 301 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
 302 checkCOrAsmOrDotNetOrInterp HscILX         = Nothing
 303 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 304 checkCOrAsmOrDotNetOrInterp other
 305    = Just (text "requires interpreted, C, native or .NET ILX code generation")
 306
 307 checkCg check
 308  = getDOpts             `thenM` \ dflags ->
 309    let hscLang = dopt_HscLang dflags in
 310    case hscLang of
 311      HscNothing -> returnM ()
 312      otherwise  ->
 313        case check hscLang of
 314          Nothing  -> returnM ()
 315          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 316 \end{code}
 317
 318 Warnings
 319
 320 \begin{code}
 321 check :: Bool -> Message -> TcM ()
 322 check True _       = returnM ()
 323 check _    the_err = addErrTc the_err
 324
 325 illegalForeignTyErr arg_or_res ty
 326   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
 327                 ptext SLIT("type in foreign declaration:")])
 328          4 (hsep [ppr ty])
 329
 330 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 331 argument = text "argument"
 332 result   = text "result"
 333
 334 badCName :: CLabelString -> Message
 335 badCName target
 336    = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
 337
 338 foreignDeclCtxt fo
 339   = hang (ptext SLIT("When checking declaration:"))
 340          4 (ppr fo)
 341 \end{code}
 342