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 \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)  $ do
  80    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_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
  91    imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
  92    -- can't use sig_ty here because it :: Type and we need HsType Id
  93    -- hence the undefined
  94    return (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) = do
 101     checkCg checkDotnet
 102     dflags <- getDOpts
 103     checkForeignArgs (isFFIDotnetTy dflags) arg_tys
 104     checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
 105     let (DNCallSpec isStatic kind _ _ _ _) = spec
 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 -> return ()
 113        _ -> return ()
 114     return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 115
 116 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = do
 117     checkCg checkCOrAsm
 118     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
 119     return idecl
 120
 121 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
 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
 128     checkCConv cconv
 129     case arg_tys of
 130         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
 131                         checkForeignRes nonIOok  isFFIExportResultTy res1_ty
 132                         checkForeignRes mustBeIO isFFIDynResultTy    res_ty
 133                         checkFEDArgs arg1_tys
 134                   where
 135                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
 136         other -> addErrTc (illegalForeignTyErr empty sig_ty)
 137     return idecl
 138
 139 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
 140   | isDynamicTarget target = do -- Foreign import dynamic
 141       checkCg checkCOrAsmOrInterp
 142       checkCConv cconv
 143       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
 144         []                -> do
 145           check False (illegalForeignTyErr empty sig_ty)
 146           return idecl
 147         (arg1_ty:arg_tys) -> do
 148           dflags <- getDOpts
 149           check (isFFIDynArgumentTy arg1_ty)
 150                 (illegalForeignTyErr argument arg1_ty)
 151           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
 152           checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 153           return idecl
 154   | otherwise = do              -- Normal foreign import
 155       checkCg (checkCOrAsmOrDotNetOrInterp)
 156       checkCConv cconv
 157       checkCTarget target
 158       dflags <- getDOpts
 159       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
 160       checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 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) = do
 166     checkCg checkCOrAsmOrDotNetOrInterp
 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 = return ()
 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 = do
 206        (b, f) <- wrapLocSndM tcFExport fe
 207        return (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)      $ do
 212
 213    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
 214    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
 215
 216    tcCheckFEType sig_ty spec
 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    uniq <- newUnique
 224    mod <- getModule
 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
 240    return (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 _)) = do
 247     check (isCLabelString str) (badCName str)
 248     checkForeignArgs isFFIExternalTy arg_tys
 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   = mapM_ go tys
 270   where
 271     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 272
 273 ------------ Checking result types for foreign calls ----------------------
 274 -- Check that the type has the form
 275 --    (IO t) or (t) , and that t satisfies the given predicate.
 276 --
 277 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
 278
 279 nonIOok  = True
 280 mustBeIO = False
 281
 282 checkForeignRes non_io_result_ok pred_res_ty ty
 283         -- (IO t) is ok, and so is any newtype wrapping thereof
 284   | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
 285     pred_res_ty res_ty
 286   = return ()
 287
 288   | otherwise
 289   = check (non_io_result_ok && pred_res_ty ty)
 290           (illegalForeignTyErr result ty)
 291 \end{code}
 292
 293 \begin{code}
 294 #if defined(mingw32_TARGET_OS)
 295 checkDotnet HscC   = Nothing
 296 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
 297 #else
 298 checkDotnet other  = Just (text "requires .NET support (-filx or win32)")
 299 #endif
 300
 301 checkCOrAsm HscC   = Nothing
 302 checkCOrAsm HscAsm = Nothing
 303 checkCOrAsm other
 304    = Just (text "requires via-C or native code generation (-fvia-C)")
 305
 306 checkCOrAsmOrInterp HscC           = Nothing
 307 checkCOrAsmOrInterp HscAsm         = Nothing
 308 checkCOrAsmOrInterp HscInterpreted = Nothing
 309 checkCOrAsmOrInterp other
 310    = Just (text "requires interpreted, C or native code generation")
 311
 312 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 313 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
 314 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 315 checkCOrAsmOrDotNetOrInterp other
 316    = Just (text "requires interpreted, C or native code generation")
 317
 318 checkCg check = do
 319    dflags <- getDOpts
 320    let target = hscTarget dflags
 321    case target of
 322      HscNothing -> return ()
 323      otherwise  ->
 324        case check target of
 325          Nothing  -> return ()
 326          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 327 \end{code}
 328
 329 Calling conventions
 330
 331 \begin{code}
 332 checkCConv :: CCallConv -> TcM ()
 333 checkCConv CCallConv  = return ()
 334 #if i386_TARGET_ARCH
 335 checkCConv StdCallConv = return ()
 336 #else
 337 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
 338 #endif
 339 \end{code}
 340
 341 Warnings
 342
 343 \begin{code}
 344 check :: Bool -> Message -> TcM ()
 345 check True _       = return ()
 346 check _    the_err = addErrTc the_err
 347
 348 illegalForeignTyErr arg_or_res ty
 349   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res,
 350                 ptext SLIT("type in foreign declaration:")])
 351          4 (hsep [ppr ty])
 352
 353 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 354 argument = text "argument"
 355 result   = text "result"
 356
 357 badCName :: CLabelString -> Message
 358 badCName target
 359    = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
 360
 361 foreignDeclCtxt fo
 362   = hang (ptext SLIT("When checking declaration:"))
 363          4 (ppr fo)
 364
 365 illegalDNMethodSig
 366   = ptext SLIT("'This pointer' expected as last argument")
 367
 368 \end{code}
 369