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