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