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 {-# OPTIONS -w #-}
  16 -- The above warning supression flag is a temporary kludge.
  17 -- While working on this module you are encouraged to remove it and fix
  18 -- any warnings in the module. See
  19 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
  20 -- for details
  21
  22 module TcForeign
  23         (
  24           tcForeignImports
  25         , tcForeignExports
  26         ) where
  27
  28 #include "HsVersions.h"
  29
  30 import HsSyn
  31
  32 import TcRnMonad
  33 import TcHsType
  34 import TcExpr
  35
  36 import ForeignCall
  37 import ErrUtils
  38 import Id
  39 #if alpha_TARGET_ARCH
  40 import Type
  41 import SMRep
  42 import MachOp
  43 #endif
  44 import Name
  45 import OccName
  46 import TcType
  47 import DynFlags
  48 import Outputable
  49 import SrcLoc
  50 import Bag
  51 import Unique
  52 \end{code}
  53
  54 \begin{code}
  55 -- Defines a binding
  56 isForeignImport :: LForeignDecl name -> Bool
  57 isForeignImport (L _ (ForeignImport _ _ _)) = True
  58 isForeignImport _                             = False
  59
  60 -- Exports a binding
  61 isForeignExport :: LForeignDecl name -> Bool
  62 isForeignExport (L _ (ForeignExport _ _ _)) = True
  63 isForeignExport _                             = False
  64 \end{code}
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 \subsection{Imports}
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 \begin{code}
  73 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
  74 tcForeignImports decls
  75   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
  76
  77 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
  78 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
  79  = addErrCtxt (foreignDeclCtxt fo)      $
  80    tcHsSigType (ForSigCtxt nm) hs_ty    `thenM` \ sig_ty ->
  81    let
  82       -- drop the foralls before inspecting the structure
  83       -- of the foreign type.
  84         (_, t_ty)         = tcSplitForAllTys sig_ty
  85         (arg_tys, res_ty) = tcSplitFunTys t_ty
  86         id                = mkLocalId nm sig_ty
  87                 -- Use a LocalId to obey the invariant that locally-defined
  88                 -- things are LocalIds.  However, it does not need zonking,
  89                 -- (so TcHsSyn.zonkForeignExports ignores it).
  90    in
  91    tcCheckFIType sig_ty arg_tys res_ty imp_decl         `thenM` \ imp_decl' ->
  92    -- can't use sig_ty here because it :: Type and we need HsType Id
  93    -- hence the undefined
  94    returnM (id, ForeignImport (L loc id) undefined imp_decl')
  95 \end{code}
  96
  97
  98 ------------ Checking types for foreign import ----------------------
  99 \begin{code}
 100 tcCheckFIType _ arg_tys res_ty (DNImport spec)
 101   = checkCg checkDotnet  `thenM_`
 102     getDOpts             `thenM`  \ dflags ->
 103     checkForeignArgs (isFFIDotnetTy dflags) arg_tys     `thenM_`
 104     checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
 105     let (DNCallSpec isStatic kind _ _ _ _) = spec in
 106     (case kind of
 107        DNMethod | not isStatic ->
 108          case arg_tys of
 109            [] -> addErrTc illegalDNMethodSig
 110            _
 111             | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
 112             | otherwise -> returnM ()
 113        _ -> returnM ()) `thenM_`
 114     returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 115
 116 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
 117   = checkCg checkCOrAsm         `thenM_`
 118     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
 119     return idecl
 120
 121 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
 122   =     -- Foreign wrapper (former f.e.d.)
 123         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
 124         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
 125         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
 126         -- is DEPRECATED, though.
 127     checkCg checkCOrAsmOrInterp `thenM_`
 128     checkCConv cconv            `thenM_`
 129     (case arg_tys of
 130         [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys               `thenM_`
 131                      checkForeignRes nonIOok  isFFIExportResultTy res1_ty    `thenM_`
 132                      checkForeignRes mustBeIO isFFIDynResultTy    res_ty     `thenM_`
 133                      checkFEDArgs arg1_tys
 134                   where
 135                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
 136         other -> addErrTc (illegalForeignTyErr empty sig_ty)    )            `thenM_`
 137     return idecl
 138
 139 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
 140   | isDynamicTarget target      -- Foreign import dynamic
 141   = checkCg checkCOrAsmOrInterp         `thenM_`
 142     checkCConv cconv                    `thenM_`
 143     case arg_tys of             -- The first arg must be Ptr, FunPtr, or Addr
 144       []                ->
 145         check False (illegalForeignTyErr empty sig_ty) `thenM_`
 146         return idecl
 147       (arg1_ty:arg_tys) ->
 148         getDOpts                                                     `thenM` \ dflags ->
 149         check (isFFIDynArgumentTy arg1_ty)
 150               (illegalForeignTyErr argument arg1_ty)                 `thenM_`
 151         checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys     `thenM_`
 152         checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty  `thenM_`
 153         return idecl
 154   | otherwise           -- Normal foreign import
 155   = checkCg (checkCOrAsmOrDotNetOrInterp)                       `thenM_`
 156     checkCConv cconv                                            `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 . argMachRep . primRepToCgRep) prim_rep
 184                         | prim_rep <- map typePrimRep arg_tys,
 185                           primRepHint prim_rep /= FloatHint ]
 186     err = ptext SLIT("On Alpha, I can only handle 32 bytes of 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 (emptyLHsBinds, []) (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) =
 211    addErrCtxt (foreignDeclCtxt fo)      $
 212
 213    tcHsSigType (ForSigCtxt nm) hs_ty    `thenM` \ sig_ty ->
 214    tcPolyExpr (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           -- We need to give a name to the new top-level binding that
 227           -- is *stable* (i.e. the compiler won't change it later),
 228           -- because this name will be referred to by the C code stub.
 229           -- Furthermore, the name must be unique (see #1533).  If the
 230           -- same function is foreign-exported multiple times, the
 231           -- top-level bindings generated must not have the same name.
 232           -- Hence we create an External name (doesn't change), and we
 233           -- append a Unique to the string right here.
 234         uniq_str = showSDoc (pprUnique uniq)
 235         occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
 236         gnm  = mkExternalName uniq mod (mkForeignExportOcc occ) loc
 237         id   = mkExportedLocalId gnm sig_ty
 238         bind = L loc (VarBind id rhs)
 239    in
 240    returnM (bind, ForeignExport (L loc id) undefined spec)
 241 \end{code}
 242
 243 ------------ Checking argument types for foreign export ----------------------
 244
 245 \begin{code}
 246 tcCheckFEType sig_ty (CExport (CExportStatic str _))
 247   = check (isCLabelString str) (badCName str)           `thenM_`
 248     checkForeignArgs isFFIExternalTy arg_tys            `thenM_`
 249     checkForeignRes nonIOok isFFIExportResultTy res_ty
 250   where
 251       -- Drop the foralls before inspecting n
 252       -- the structure of the foreign type.
 253     (_, t_ty) = tcSplitForAllTys sig_ty
 254     (arg_tys, res_ty) = tcSplitFunTys t_ty
 255 \end{code}
 256
 257
 258
 259 %************************************************************************
 260 %*                                                                      *
 261 \subsection{Miscellaneous}
 262 %*                                                                      *
 263 %************************************************************************
 264
 265 \begin{code}
 266 ------------ Checking argument types for foreign import ----------------------
 267 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
 268 checkForeignArgs pred tys
 269   = mappM go tys                `thenM_`
 270     returnM ()
 271   where
 272     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 273
 274 ------------ Checking result types for foreign calls ----------------------
 275 -- Check that the type has the form
 276 --    (IO t) or (t) , and that t satisfies the given predicate.
 277 --
 278 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
 279
 280 nonIOok  = True
 281 mustBeIO = False
 282
 283 checkForeignRes non_io_result_ok pred_res_ty ty
 284         -- (IO t) is ok, and so is any newtype wrapping thereof
 285   | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
 286     pred_res_ty res_ty
 287   = returnM ()
 288
 289   | otherwise
 290   = check (non_io_result_ok && pred_res_ty ty)
 291           (illegalForeignTyErr result ty)
 292 \end{code}
 293
 294 \begin{code}
 295 #if defined(mingw32_TARGET_OS)
 296 checkDotnet HscC   = Nothing
 297 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
 298 #else
 299 checkDotnet other  = Just (text "requires .NET support (-filx or win32)")
 300 #endif
 301
 302 checkCOrAsm HscC   = Nothing
 303 checkCOrAsm HscAsm = Nothing
 304 checkCOrAsm other
 305    = Just (text "requires via-C or native code generation (-fvia-C)")
 306
 307 checkCOrAsmOrInterp HscC           = Nothing
 308 checkCOrAsmOrInterp HscAsm         = Nothing
 309 checkCOrAsmOrInterp HscInterpreted = Nothing
 310 checkCOrAsmOrInterp other
 311    = Just (text "requires interpreted, C or native code generation")
 312
 313 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 314 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
 315 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 316 checkCOrAsmOrDotNetOrInterp other
 317    = Just (text "requires interpreted, C or native code generation")
 318
 319 checkCg check
 320  = getDOpts             `thenM` \ dflags ->
 321    let target = hscTarget dflags in
 322    case target of
 323      HscNothing -> returnM ()
 324      otherwise  ->
 325        case check target of
 326          Nothing  -> returnM ()
 327          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 328 \end{code}
 329
 330 Calling conventions
 331
 332 \begin{code}
 333 checkCConv :: CCallConv -> TcM ()
 334 checkCConv CCallConv  = return ()
 335 #if i386_TARGET_ARCH
 336 checkCConv StdCallConv = return ()
 337 #else
 338 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
 339 #endif
 340 \end{code}
 341
 342 Warnings
 343
 344 \begin{code}
 345 check :: Bool -> Message -> TcM ()
 346 check True _       = returnM ()
 347 check _    the_err = addErrTc the_err
 348
 349 illegalForeignTyErr arg_or_res ty
 350   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
 351                 ptext SLIT("type in foreign declaration:")])
 352          4 (hsep [ppr ty])
 353
 354 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 355 argument = text "argument"
 356 result   = text "result"
 357
 358 badCName :: CLabelString -> Message
 359 badCName target
 360    = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
 361
 362 foreignDeclCtxt fo
 363   = hang (ptext SLIT("When checking declaration:"))
 364          4 (ppr fo)
 365
 366 illegalDNMethodSig
 367   = ptext SLIT("'This pointer' expected as last argument")
 368
 369 \end{code}
 370