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))
 218                               (srcSpanStart loc)
 219         id   = mkExportedLocalId gnm sig_ty
 220         bind = L loc (VarBind id rhs)
 221    in
 222    returnM (bind, ForeignExport (L loc id) undefined spec)
 223 \end{code}
 224
 225 ------------ Checking argument types for foreign export ----------------------
 226
 227 \begin{code}
 228 tcCheckFEType sig_ty (CExport (CExportStatic str _))
 229   = check (isCLabelString str) (badCName str)           `thenM_`
 230     checkForeignArgs isFFIExternalTy arg_tys            `thenM_`
 231     checkForeignRes nonIOok isFFIExportResultTy res_ty
 232   where
 233       -- Drop the foralls before inspecting n
 234       -- the structure of the foreign type.
 235     (_, t_ty) = tcSplitForAllTys sig_ty
 236     (arg_tys, res_ty) = tcSplitFunTys t_ty
 237 \end{code}
 238
 239
 240
 241 %************************************************************************
 242 %*                                                                      *
 243 \subsection{Miscellaneous}
 244 %*                                                                      *
 245 %************************************************************************
 246
 247 \begin{code}
 248 ------------ Checking argument types for foreign import ----------------------
 249 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
 250 checkForeignArgs pred tys
 251   = mappM go tys                `thenM_`
 252     returnM ()
 253   where
 254     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 255
 256 ------------ Checking result types for foreign calls ----------------------
 257 -- Check that the type has the form
 258 --    (IO t) or (t) , and that t satisfies the given predicate.
 259 --
 260 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
 261
 262 nonIOok  = True
 263 mustBeIO = False
 264
 265 checkForeignRes non_io_result_ok pred_res_ty ty
 266         -- (IO t) is ok, and so is any newtype wrapping thereof
 267   | Just (io, res_ty) <- tcSplitIOType_maybe ty,
 268     pred_res_ty res_ty
 269   = returnM ()
 270
 271   | otherwise
 272   = check (non_io_result_ok && pred_res_ty ty)
 273           (illegalForeignTyErr result ty)
 274 \end{code}
 275
 276 \begin{code}
 277 #if defined(mingw32_TARGET_OS)
 278 checkDotnet HscC   = Nothing
 279 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
 280 #else
 281 checkDotnet other  = Just (text "requires .NET support (-filx or win32)")
 282 #endif
 283
 284 checkCOrAsm HscC   = Nothing
 285 checkCOrAsm HscAsm = Nothing
 286 checkCOrAsm other
 287    = Just (text "requires via-C or native code generation (-fvia-C)")
 288
 289 checkCOrAsmOrInterp HscC           = Nothing
 290 checkCOrAsmOrInterp HscAsm         = Nothing
 291 checkCOrAsmOrInterp HscInterpreted = Nothing
 292 checkCOrAsmOrInterp other
 293    = Just (text "requires interpreted, C or native code generation")
 294
 295 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 296 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
 297 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 298 checkCOrAsmOrDotNetOrInterp other
 299    = Just (text "requires interpreted, C or native code generation")
 300
 301 checkCg check
 302  = getDOpts             `thenM` \ dflags ->
 303    let target = hscTarget dflags in
 304    case target of
 305      HscNothing -> returnM ()
 306      otherwise  ->
 307        case check target of
 308          Nothing  -> returnM ()
 309          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 310 \end{code}
 311
 312 Calling conventions
 313
 314 \begin{code}
 315 checkCConv :: CCallConv -> TcM ()
 316 checkCConv CCallConv  = return ()
 317 #if i386_TARGET_ARCH
 318 checkCConv StdCallConv = return ()
 319 #else
 320 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
 321 #endif
 322 \end{code}
 323
 324 Warnings
 325
 326 \begin{code}
 327 check :: Bool -> Message -> TcM ()
 328 check True _       = returnM ()
 329 check _    the_err = addErrTc the_err
 330
 331 illegalForeignTyErr arg_or_res ty
 332   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
 333                 ptext SLIT("type in foreign declaration:")])
 334          4 (hsep [ppr ty])
 335
 336 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 337 argument = text "argument"
 338 result   = text "result"
 339
 340 badCName :: CLabelString -> Message
 341 badCName target
 342    = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
 343
 344 foreignDeclCtxt fo
 345   = hang (ptext SLIT("When checking declaration:"))
 346          4 (ppr fo)
 347
 348 illegalDNMethodSig
 349   = ptext SLIT("'This pointer' expected as last argument")
 350
 351 \end{code}
 352