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