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       checkMissingAmpersand dflags arg_tys res_ty
 158       return idecl
 159
 160 -- This makes a convenient place to check
 161 -- that the C identifier is valid for C
 162 checkCTarget :: CCallTarget -> TcM ()
 163 checkCTarget (StaticTarget str) = do
 164     checkCg checkCOrAsmOrDotNetOrInterp
 165     check (isCLabelString str) (badCName str)
 166 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
 167
 168 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
 169 checkMissingAmpersand dflags arg_tys res_ty
 170   | null arg_tys && isFunPtrTy res_ty &&
 171     dopt Opt_WarnDodgyForeignImports dflags
 172   = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
 173   | otherwise
 174   = return ()
 175 \end{code}
 176
 177 On an Alpha, with foreign export dynamic, due to a giant hack when
 178 building adjustor thunks, we only allow 4 integer arguments with
 179 foreign export dynamic (i.e., 32 bytes of arguments after padding each
 180 argument to a quadword, excluding floating-point arguments).
 181
 182 The check is needed for both via-C and native-code routes
 183
 184 \begin{code}
 185 #include "nativeGen/NCG.h"
 186
 187 checkFEDArgs :: [Type] -> TcM ()
 188 #if alpha_TARGET_ARCH
 189 checkFEDArgs arg_tys
 190   = check (integral_args <= 32) err
 191   where
 192     integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
 193                         | prim_rep <- map typePrimRep arg_tys,
 194                           primRepHint prim_rep /= FloatHint ]
 195     err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
 196 #else
 197 checkFEDArgs _ = return ()
 198 #endif
 199 \end{code}
 200
 201
 202 %************************************************************************
 203 %*                                                                      *
 204 \subsection{Exports}
 205 %*                                                                      *
 206 %************************************************************************
 207
 208 \begin{code}
 209 tcForeignExports :: [LForeignDecl Name]
 210                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
 211 tcForeignExports decls
 212   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
 213   where
 214    combine (binds, fs) fe = do
 215        (b, f) <- wrapLocSndM tcFExport fe
 216        return (b `consBag` binds, f:fs)
 217
 218 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
 219 tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
 220    addErrCtxt (foreignDeclCtxt fo)      $ do
 221
 222    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
 223    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
 224
 225    tcCheckFEType sig_ty spec
 226
 227           -- we're exporting a function, but at a type possibly more
 228           -- constrained than its declared/inferred type. Hence the need
 229           -- to create a local binding which will call the exported function
 230           -- at a particular type (and, maybe, overloading).
 231
 232    uniq <- newUnique
 233    mod <- getModule
 234    let
 235           -- We need to give a name to the new top-level binding that
 236           -- is *stable* (i.e. the compiler won't change it later),
 237           -- because this name will be referred to by the C code stub.
 238           -- Furthermore, the name must be unique (see #1533).  If the
 239           -- same function is foreign-exported multiple times, the
 240           -- top-level bindings generated must not have the same name.
 241           -- Hence we create an External name (doesn't change), and we
 242           -- append a Unique to the string right here.
 243         uniq_str = showSDoc (pprUnique uniq)
 244         occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
 245         gnm  = mkExternalName uniq mod (mkForeignExportOcc occ) loc
 246         id   = mkExportedLocalId gnm sig_ty
 247         bind = L loc (VarBind id rhs)
 248
 249    return (bind, ForeignExport (L loc id) undefined spec)
 250 tcFExport d = pprPanic "tcFExport" (ppr d)
 251 \end{code}
 252
 253 ------------ Checking argument types for foreign export ----------------------
 254
 255 \begin{code}
 256 tcCheckFEType :: Type -> ForeignExport -> TcM ()
 257 tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
 258     check (isCLabelString str) (badCName str)
 259     checkForeignArgs isFFIExternalTy arg_tys
 260     checkForeignRes nonIOok isFFIExportResultTy res_ty
 261   where
 262       -- Drop the foralls before inspecting n
 263       -- the structure of the foreign type.
 264     (_, t_ty) = tcSplitForAllTys sig_ty
 265     (arg_tys, res_ty) = tcSplitFunTys t_ty
 266 tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
 267 \end{code}
 268
 269
 270
 271 %************************************************************************
 272 %*                                                                      *
 273 \subsection{Miscellaneous}
 274 %*                                                                      *
 275 %************************************************************************
 276
 277 \begin{code}
 278 ------------ Checking argument types for foreign import ----------------------
 279 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
 280 checkForeignArgs pred tys
 281   = mapM_ go tys
 282   where
 283     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 284
 285 ------------ Checking result types for foreign calls ----------------------
 286 -- Check that the type has the form
 287 --    (IO t) or (t) , and that t satisfies the given predicate.
 288 --
 289 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
 290
 291 nonIOok, mustBeIO :: Bool
 292 nonIOok  = True
 293 mustBeIO = False
 294
 295 checkForeignRes non_io_result_ok pred_res_ty ty
 296         -- (IO t) is ok, and so is any newtype wrapping thereof
 297   | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
 298     pred_res_ty res_ty
 299   = return ()
 300
 301   | otherwise
 302   = check (non_io_result_ok && pred_res_ty ty)
 303           (illegalForeignTyErr result ty)
 304 \end{code}
 305
 306 \begin{code}
 307 checkDotnet :: HscTarget -> Maybe SDoc
 308 #if defined(mingw32_TARGET_OS)
 309 checkDotnet HscC   = Nothing
 310 checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
 311 #else
 312 checkDotnet _      = Just (text "requires .NET support (-filx or win32)")
 313 #endif
 314
 315 checkCOrAsm :: HscTarget -> Maybe SDoc
 316 checkCOrAsm HscC   = Nothing
 317 checkCOrAsm HscAsm = Nothing
 318 checkCOrAsm _
 319    = Just (text "requires via-C or native code generation (-fvia-C)")
 320
 321 checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc
 322 checkCOrAsmOrInterp HscC           = Nothing
 323 checkCOrAsmOrInterp HscAsm         = Nothing
 324 checkCOrAsmOrInterp HscInterpreted = Nothing
 325 checkCOrAsmOrInterp _
 326    = Just (text "requires interpreted, C or native code generation")
 327
 328 checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
 329 checkCOrAsmOrDotNetOrInterp HscC           = Nothing
 330 checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
 331 checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
 332 checkCOrAsmOrDotNetOrInterp _
 333    = Just (text "requires interpreted, C or native code generation")
 334
 335 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
 336 checkCg check = do
 337    dflags <- getDOpts
 338    let target = hscTarget dflags
 339    case target of
 340      HscNothing -> return ()
 341      _ ->
 342        case check target of
 343          Nothing  -> return ()
 344          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 345 \end{code}
 346
 347 Calling conventions
 348
 349 \begin{code}
 350 checkCConv :: CCallConv -> TcM ()
 351 checkCConv CCallConv  = return ()
 352 #if i386_TARGET_ARCH
 353 checkCConv StdCallConv = return ()
 354 #else
 355 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
 356 #endif
 357 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
 358 \end{code}
 359
 360 Warnings
 361
 362 \begin{code}
 363 check :: Bool -> Message -> TcM ()
 364 check True _       = return ()
 365 check _    the_err = addErrTc the_err
 366
 367 illegalForeignTyErr :: SDoc -> Type -> SDoc
 368 illegalForeignTyErr arg_or_res ty
 369   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
 370                 ptext (sLit "type in foreign declaration:")])
 371          4 (hsep [ppr ty])
 372
 373 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 374 argument, result :: SDoc
 375 argument = text "argument"
 376 result   = text "result"
 377
 378 badCName :: CLabelString -> Message
 379 badCName target
 380    = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
 381
 382 foreignDeclCtxt :: ForeignDecl Name -> SDoc
 383 foreignDeclCtxt fo
 384   = hang (ptext (sLit "When checking declaration:"))
 385          4 (ppr fo)
 386
 387 illegalDNMethodSig :: SDoc
 388 illegalDNMethodSig
 389   = ptext (sLit "'This pointer' expected as last argument")
 390
 391 \end{code}
 392