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 import FastString
  46 \end{code}
  47
  48 \begin{code}
  49 -- Defines a binding
  50 isForeignImport :: LForeignDecl name -> Bool
  51 isForeignImport (L _ (ForeignImport _ _ _)) = True
  52 isForeignImport _                             = False
  53
  54 -- Exports a binding
  55 isForeignExport :: LForeignDecl name -> Bool
  56 isForeignExport (L _ (ForeignExport _ _ _)) = True
  57 isForeignExport _                             = False
  58 \end{code}
  59
  60 %************************************************************************
  61 %*                                                                      *
  62 \subsection{Imports}
  63 %*                                                                      *
  64 %************************************************************************
  65
  66 \begin{code}
  67 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
  68 tcForeignImports decls
  69   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
  70
  71 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
  72 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
  73  = addErrCtxt (foreignDeclCtxt fo)  $ do
  74    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
  75    let
  76       -- drop the foralls before inspecting the structure
  77       -- of the foreign type.
  78         (_, t_ty)         = tcSplitForAllTys sig_ty
  79         (arg_tys, res_ty) = tcSplitFunTys t_ty
  80         id                = mkLocalId nm sig_ty
  81                 -- Use a LocalId to obey the invariant that locally-defined
  82                 -- things are LocalIds.  However, it does not need zonking,
  83                 -- (so TcHsSyn.zonkForeignExports ignores it).
  84
  85    imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
  86    -- can't use sig_ty here because it :: Type and we need HsType Id
  87    -- hence the undefined
  88    return (id, ForeignImport (L loc id) undefined imp_decl')
  89 tcFImport d = pprPanic "tcFImport" (ppr d)
  90 \end{code}
  91
  92
  93 ------------ Checking types for foreign import ----------------------
  94 \begin{code}
  95 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
  96 tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
  97     checkCg checkDotnet
  98     dflags <- getDOpts
  99     checkForeignArgs (isFFIDotnetTy dflags) arg_tys
 100     checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
 101     let (DNCallSpec isStatic kind _ _ _ _) = spec
 102     case kind of
 103        DNMethod | not isStatic ->
 104          case arg_tys of
 105            [] -> addErrTc illegalDNMethodSig
 106            _
 107             | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
 108             | otherwise -> return ()
 109        _ -> return ()
 110     return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 111
 112 tcCheckFIType sig_ty _ _ idecl@(CImport _ _ _ _ (CLabel _)) = do
 113     checkCg checkCOrAsm
 114     check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
 115     return idecl
 116
 117 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
 118         -- Foreign wrapper (former f.e.d.)
 119         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
 120         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
 121         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
 122         -- is DEPRECATED, though.
 123     checkCg checkCOrAsmOrInterp
 124     checkCConv cconv
 125     case arg_tys of
 126         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
 127                         checkForeignRes nonIOok  isFFIExportResultTy res1_ty
 128                         checkForeignRes mustBeIO isFFIDynResultTy    res_ty
 129                         checkFEDArgs arg1_tys
 130                   where
 131                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
 132         _ -> addErrTc (illegalForeignTyErr empty sig_ty)
 133     return idecl
 134
 135 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
 136   | isDynamicTarget target = do -- Foreign import dynamic
 137       checkCg checkCOrAsmOrInterp
 138       checkCConv cconv
 139       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
 140         []                -> do
 141           check False (illegalForeignTyErr empty sig_ty)
 142           return idecl
 143         (arg1_ty:arg_tys) -> do
 144           dflags <- getDOpts
 145           check (isFFIDynArgumentTy arg1_ty)
 146                 (illegalForeignTyErr argument arg1_ty)
 147           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
 148           checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 149           return idecl
 150   | otherwise = do              -- Normal foreign import
 151       checkCg (checkCOrAsmOrDotNetOrInterp)
 152       checkCConv cconv
 153       checkCTarget target
 154       dflags <- getDOpts
 155       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
 156       checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 157       return idecl
 158
 159 -- This makes a convenient place to check
 160 -- that the C identifier is valid for C
 161 checkCTarget :: CCallTarget -> TcM ()
 162 checkCTarget (StaticTarget str) = do
 163     checkCg checkCOrAsmOrDotNetOrInterp
 164     check (isCLabelString str) (badCName str)
 165 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
 166 \end{code}
 167
 168 On an Alpha, with foreign export dynamic, due to a giant hack when
 169 building adjustor thunks, we only allow 4 integer arguments with
 170 foreign export dynamic (i.e., 32 bytes of arguments after padding each
 171 argument to a quadword, excluding floating-point arguments).
 172
 173 The check is needed for both via-C and native-code routes
 174
 175 \begin{code}
 176 #include "nativeGen/NCG.h"
 177
 178 checkFEDArgs :: [Type] -> TcM ()
 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 _ = 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 tcFExport d = pprPanic "tcFExport" (ppr d)
 242 \end{code}
 243
 244 ------------ Checking argument types for foreign export ----------------------
 245
 246 \begin{code}
 247 tcCheckFEType :: Type -> ForeignExport -> TcM ()
 248 tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
 249     check (isCLabelString str) (badCName str)
 250     checkForeignArgs isFFIExternalTy arg_tys
 251     checkForeignRes nonIOok isFFIExportResultTy res_ty
 252   where
 253       -- Drop the foralls before inspecting n
 254       -- the structure of the foreign type.
 255     (_, t_ty) = tcSplitForAllTys sig_ty
 256     (arg_tys, res_ty) = tcSplitFunTys t_ty
 257 tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
 258 \end{code}
 259
 260
 261
 262 %************************************************************************
 263 %*                                                                      *
 264 \subsection{Miscellaneous}
 265 %*                                                                      *
 266 %************************************************************************
 267
 268 \begin{code}
 269 ------------ Checking argument types for foreign import ----------------------
 270 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
 271 checkForeignArgs pred tys
 272   = mapM_ go tys
 273   where
 274     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 275
 276 ------------ Checking result types for foreign calls ----------------------
 277 -- Check that the type has the form
 278 --    (IO t) or (t) , and that t satisfies the given predicate.
 279 --
 280 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
 281
 282 nonIOok, mustBeIO :: Bool
 283 nonIOok  = True
 284 mustBeIO = False
 285
 286 checkForeignRes non_io_result_ok pred_res_ty ty
 287         -- (IO t) is ok, and so is any newtype wrapping thereof
 288   | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
 289     pred_res_ty res_ty
 290   = return ()
 291
 292   | otherwise
 293   = check (non_io_result_ok && pred_res_ty ty)
 294           (illegalForeignTyErr result ty)
 295 \end{code}
 296
 297 \begin{code}
 298 checkDotnet :: HscTarget -> Maybe SDoc
 299 #if defined(mingw32_TARGET_OS)
 300 checkDotnet HscC   = Nothing
 301 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
 302 #else
 303 checkDotnet _      = Just (text "requires .NET support (-filx or win32)")
 304 #endif
 305
 306 checkCOrAsm :: HscTarget -> Maybe SDoc
 307 checkCOrAsm HscC   = Nothing
 308 checkCOrAsm HscAsm = Nothing
 309 checkCOrAsm _
 310    = Just (text "requires via-C or native code generation (-fvia-C)")
 311
 312 checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
 313 checkCOrAsmOrInterp HscC           = Nothing
 314 checkCOrAsmOrInterp HscAsm         = Nothing
 315 checkCOrAsmOrInterp HscInterpreted = Nothing
 316 checkCOrAsmOrInterp _
 317    = Just (text "requires interpreted, C or native code generation")
 318
 319 checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
 320 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 321 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
 322 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 323 checkCOrAsmOrDotNetOrInterp _
 324    = Just (text "requires interpreted, C or native code generation")
 325
 326 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
 327 checkCg check = do
 328    dflags <- getDOpts
 329    let target = hscTarget dflags
 330    case target of
 331      HscNothing -> return ()
 332      _ ->
 333        case check target of
 334          Nothing  -> return ()
 335          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 336 \end{code}
 337
 338 Calling conventions
 339
 340 \begin{code}
 341 checkCConv :: CCallConv -> TcM ()
 342 checkCConv CCallConv  = return ()
 343 #if i386_TARGET_ARCH
 344 checkCConv StdCallConv = return ()
 345 #else
 346 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
 347 #endif
 348 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
 349 \end{code}
 350
 351 Warnings
 352
 353 \begin{code}
 354 check :: Bool -> Message -> TcM ()
 355 check True _       = return ()
 356 check _    the_err = addErrTc the_err
 357
 358 illegalForeignTyErr :: SDoc -> Type -> SDoc
 359 illegalForeignTyErr arg_or_res ty
 360   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
 361                 ptext (sLit "type in foreign declaration:")])
 362          4 (hsep [ppr ty])
 363
 364 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 365 argument, result :: SDoc
 366 argument = text "argument"
 367 result   = text "result"
 368
 369 badCName :: CLabelString -> Message
 370 badCName target
 371    = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
 372
 373 foreignDeclCtxt :: ForeignDecl Name -> SDoc
 374 foreignDeclCtxt fo
 375   = hang (ptext (sLit "When checking declaration:"))
 376          4 (ppr fo)
 377
 378 illegalDNMethodSig :: SDoc
 379 illegalDNMethodSig
 380   = ptext (sLit "'This pointer' expected as last argument")
 381
 382 \end{code}
 383