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