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