compiler/typecheck/TcForeign.lhs

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