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/Commentary/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 import FastString
  53 \end{code}
  54
  55 \begin{code}
  56 -- Defines a binding
  57 isForeignImport :: LForeignDecl name -> Bool
  58 isForeignImport (L _ (ForeignImport _ _ _)) = True
  59 isForeignImport _                             = False
  60
  61 -- Exports a binding
  62 isForeignExport :: LForeignDecl name -> Bool
  63 isForeignExport (L _ (ForeignExport _ _ _)) = True
  64 isForeignExport _                             = False
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection{Imports}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
  75 tcForeignImports decls
  76   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
  77
  78 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
  79 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
  80  = addErrCtxt (foreignDeclCtxt fo)  $ do
  81    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
  82    let
  83       -- drop the foralls before inspecting the structure
  84       -- of the foreign type.
  85         (_, t_ty)         = tcSplitForAllTys sig_ty
  86         (arg_tys, res_ty) = tcSplitFunTys t_ty
  87         id                = mkLocalId nm sig_ty
  88                 -- Use a LocalId to obey the invariant that locally-defined
  89                 -- things are LocalIds.  However, it does not need zonking,
  90                 -- (so TcHsSyn.zonkForeignExports ignores it).
  91
  92    imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
  93    -- can't use sig_ty here because it :: Type and we need HsType Id
  94    -- hence the undefined
  95    return (id, ForeignImport (L loc id) undefined imp_decl')
  96 \end{code}
  97
  98
  99 ------------ Checking types for foreign import ----------------------
 100 \begin{code}
 101 tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
 102     checkCg checkDotnet
 103     dflags <- getDOpts
 104     checkForeignArgs (isFFIDotnetTy dflags) arg_tys
 105     checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
 106     let (DNCallSpec isStatic kind _ _ _ _) = spec
 107     case kind of
 108        DNMethod | not isStatic ->
 109          case arg_tys of
 110            [] -> addErrTc illegalDNMethodSig
 111            _
 112             | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
 113             | otherwise -> return ()
 114        _ -> return ()
 115     return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 116
 117 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = do
 118     checkCg checkCOrAsm
 119     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
 120     return idecl
 121
 122 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
 123         -- Foreign wrapper (former f.e.d.)
 124         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
 125         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
 126         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
 127         -- is DEPRECATED, though.
 128     checkCg checkCOrAsmOrInterp
 129     checkCConv cconv
 130     case arg_tys of
 131         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
 132                         checkForeignRes nonIOok  isFFIExportResultTy res1_ty
 133                         checkForeignRes mustBeIO isFFIDynResultTy    res_ty
 134                         checkFEDArgs arg1_tys
 135                   where
 136                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
 137         other -> addErrTc (illegalForeignTyErr empty sig_ty)
 138     return idecl
 139
 140 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
 141   | isDynamicTarget target = do -- Foreign import dynamic
 142       checkCg checkCOrAsmOrInterp
 143       checkCConv cconv
 144       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
 145         []                -> do
 146           check False (illegalForeignTyErr empty sig_ty)
 147           return idecl
 148         (arg1_ty:arg_tys) -> do
 149           dflags <- getDOpts
 150           check (isFFIDynArgumentTy arg1_ty)
 151                 (illegalForeignTyErr argument arg1_ty)
 152           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
 153           checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 154           return idecl
 155   | otherwise = do              -- Normal foreign import
 156       checkCg (checkCOrAsmOrDotNetOrInterp)
 157       checkCConv cconv
 158       checkCTarget target
 159       dflags <- getDOpts
 160       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
 161       checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 162       return idecl
 163
 164 -- This makes a convenient place to check
 165 -- that the C identifier is valid for C
 166 checkCTarget (StaticTarget str) = do
 167     checkCg checkCOrAsmOrDotNetOrInterp
 168     check (isCLabelString str) (badCName str)
 169 \end{code}
 170
 171 On an Alpha, with foreign export dynamic, due to a giant hack when
 172 building adjustor thunks, we only allow 4 integer arguments with
 173 foreign export dynamic (i.e., 32 bytes of arguments after padding each
 174 argument to a quadword, excluding floating-point arguments).
 175
 176 The check is needed for both via-C and native-code routes
 177
 178 \begin{code}
 179 #include "nativeGen/NCG.h"
 180 #if alpha_TARGET_ARCH
 181 checkFEDArgs arg_tys
 182   = check (integral_args <= 32) err
 183   where
 184     integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
 185                         | prim_rep <- map typePrimRep arg_tys,
 186                           primRepHint prim_rep /= FloatHint ]
 187     err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
 188 #else
 189 checkFEDArgs arg_tys = return ()
 190 #endif
 191 \end{code}
 192
 193
 194 %************************************************************************
 195 %*                                                                      *
 196 \subsection{Exports}
 197 %*                                                                      *
 198 %************************************************************************
 199
 200 \begin{code}
 201 tcForeignExports :: [LForeignDecl Name]
 202                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
 203 tcForeignExports decls
 204   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
 205   where
 206    combine (binds, fs) fe = do
 207        (b, f) <- wrapLocSndM tcFExport fe
 208        return (b `consBag` binds, f:fs)
 209
 210 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
 211 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
 212    addErrCtxt (foreignDeclCtxt fo)      $ do
 213
 214    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
 215    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
 216
 217    tcCheckFEType sig_ty spec
 218
 219           -- we're exporting a function, but at a type possibly more
 220           -- constrained than its declared/inferred type. Hence the need
 221           -- to create a local binding which will call the exported function
 222           -- at a particular type (and, maybe, overloading).
 223
 224    uniq <- newUnique
 225    mod <- getModule
 226    let
 227           -- We need to give a name to the new top-level binding that
 228           -- is *stable* (i.e. the compiler won't change it later),
 229           -- because this name will be referred to by the C code stub.
 230           -- Furthermore, the name must be unique (see #1533).  If the
 231           -- same function is foreign-exported multiple times, the
 232           -- top-level bindings generated must not have the same name.
 233           -- Hence we create an External name (doesn't change), and we
 234           -- append a Unique to the string right here.
 235         uniq_str = showSDoc (pprUnique uniq)
 236         occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
 237         gnm  = mkExternalName uniq mod (mkForeignExportOcc occ) loc
 238         id   = mkExportedLocalId gnm sig_ty
 239         bind = L loc (VarBind id rhs)
 240
 241    return (bind, ForeignExport (L loc id) undefined spec)
 242 \end{code}
 243
 244 ------------ Checking argument types for foreign export ----------------------
 245
 246 \begin{code}
 247 tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
 248     check (isCLabelString str) (badCName str)
 249     checkForeignArgs isFFIExternalTy arg_tys
 250     checkForeignRes nonIOok isFFIExportResultTy res_ty
 251   where
 252       -- Drop the foralls before inspecting n
 253       -- the structure of the foreign type.
 254     (_, t_ty) = tcSplitForAllTys sig_ty
 255     (arg_tys, res_ty) = tcSplitFunTys t_ty
 256 \end{code}
 257
 258
 259
 260 %************************************************************************
 261 %*                                                                      *
 262 \subsection{Miscellaneous}
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 \begin{code}
 267 ------------ Checking argument types for foreign import ----------------------
 268 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
 269 checkForeignArgs pred tys
 270   = mapM_ go tys
 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   = return ()
 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 = do
 320    dflags <- getDOpts
 321    let target = hscTarget dflags
 322    case target of
 323      HscNothing -> return ()
 324      otherwise  ->
 325        case check target of
 326          Nothing  -> return ()
 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 _       = return ()
 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