X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=6fe8bdc9bdeb4262ddc455da44f02ffa736bdd7c;hb=1da232fccdd01edac72180682540c4d5b5ba71ea;hp=ebae77ab55c72437ebc5f8efce0db76b0cf18852;hpb=542e4d9254f6db5c859f6a8e7892b193c56554a3;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index ebae77a..6fe8bdc 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -19,33 +19,32 @@ module TcForeign #include "HsVersions.h" -import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), +import HsSyn ( ForeignDecl(..), HsExpr(..), MonoBinds(..), ForeignImport(..), ForeignExport(..), CImportSpec(..) ) -import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) +import RnHsSyn ( RenamedForeignDecl ) -import TcMonad +import TcRnMonad import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) -import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl ) -import TcExpr ( tcExpr ) -import Inst ( emptyLIE, LIE, plusLIE ) +import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl ) +import TcExpr ( tcCheckSigma ) import ErrUtils ( Message ) -import Id ( Id, mkLocalId, setIdLocalExported ) +import Id ( Id, mkLocalId, mkVanillaGlobal, setIdLocalExported ) +import IdInfo ( noCafIdInfo ) import PrimRep ( getPrimRepSize, isFloatingRep ) -import Module ( Module ) import Type ( typePrimRep ) import OccName ( mkForeignExportOcc ) -import Name ( NamedThing(..), mkExternalName ) +import Name ( Name, NamedThing(..), mkExternalName ) import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys, isFFIArgumentTy, isFFIImportResultTy, isFFIExportResultTy, isFFILabelTy, isFFIExternalTy, isFFIDynArgumentTy, - isFFIDynResultTy, isForeignPtrTy + isFFIDynResultTy, ) -import ForeignCall ( CExportSpec(..), CCallTarget(..), +import ForeignCall ( CExportSpec(..), CCallTarget(..), CCallConv(..), isDynamicTarget, isCasmTarget ) import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) @@ -73,27 +72,29 @@ isForeignExport _ = False %************************************************************************ \begin{code} -tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl]) -tcForeignImports decls = - mapAndUnzipTc tcFImport - [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] +tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl]) +tcForeignImports decls + = mapAndUnzipM tcFImport (filter isForeignImport decls) tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty -> + = addSrcLoc src_loc $ + addErrCtxt (foreignDeclCtxt fo) $ + tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> let -- drop the foralls before inspecting the structure -- of the foreign type. (_, t_ty) = tcSplitForAllTys sig_ty (arg_tys, res_ty) = tcSplitFunTys t_ty id = mkLocalId nm sig_ty + -- Use a LocalId to obey the invariant that locally-defined + -- things are LocalIds. However, it does not need zonking, + -- (so TcHsSyn.zonkForeignExports ignores it). in - tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenNF_Tc_` + tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM_` -- can't use sig_ty here because it :: Type and we need HsType Id -- hence the undefined - returnTc (id, ForeignImport id undefined imp_decl isDeprec src_loc) + returnM (id, ForeignImport id undefined imp_decl isDeprec src_loc) \end{code} @@ -103,20 +104,20 @@ tcCheckFIType _ _ _ (DNImport _) = checkCg checkDotNet tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ (CLabel _)) - = checkCg checkCOrAsm `thenNF_Tc_` + = checkCg checkCOrAsm `thenM_` check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) -tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ CWrapper) +tcCheckFIType sig_ty arg_tys res_ty (CImport cconv _ _ _ CWrapper) = -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well -- as ft -> IO Addr is accepted, too. The use of the latter two forms -- is DEPRECATED, though. - checkCg checkCOrAsmOrInterp `thenNF_Tc_` + checkCg checkCOrAsmOrInterp `thenM_` case arg_tys of - [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenNF_Tc_` - checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenNF_Tc_` - checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenNF_Tc_` + [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_` + checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_` + checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_` checkFEDArgs arg1_tys where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty @@ -124,27 +125,27 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ CWrapper) tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target)) | isDynamicTarget target -- Foreign import dynamic - = checkCg checkCOrAsmOrInterp `thenNF_Tc_` + = checkCg checkCOrAsmOrInterp `thenM_` case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> check False (illegalForeignTyErr empty sig_ty) - (arg1_ty:arg_tys) -> getDOptsTc `thenNF_Tc` \ dflags -> + (arg1_ty:arg_tys) -> getDOpts `thenM` \ dflags -> check (isFFIDynArgumentTy arg1_ty) - (illegalForeignTyErr argument arg1_ty) `thenNF_Tc_` - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenNF_Tc_` + (illegalForeignTyErr argument arg1_ty) `thenM_` + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty | otherwise -- Normal foreign import = checkCg (if isCasmTarget target - then checkC else checkCOrAsmOrDotNetOrInterp) `thenNF_Tc_` - checkCTarget target `thenNF_Tc_` - getDOptsTc `thenNF_Tc` \ dflags -> - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenNF_Tc_` + then checkC else checkCOrAsmOrDotNetOrInterp) `thenM_` + checkCTarget target `thenM_` + getDOpts `thenM` \ dflags -> + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty -- This makes a convenient place to check -- that the C identifier is valid for C checkCTarget (StaticTarget str) - = checkCg checkCOrAsmOrDotNetOrInterp `thenNF_Tc_` + = checkCg checkCOrAsmOrDotNetOrInterp `thenM_` check (isCLabelString str) (badCName str) checkCTarget (CasmTarget _) @@ -169,7 +170,7 @@ checkFEDArgs arg_tys map typePrimRep arg_tys) err = ptext SLIT("On Alpha, I can only handle 4 non-floating-point arguments to foreign export dynamic") #else -checkFEDArgs arg_tys = returnNF_Tc () +checkFEDArgs arg_tys = returnM () #endif \end{code} @@ -181,46 +182,46 @@ checkFEDArgs arg_tys = returnNF_Tc () %************************************************************************ \begin{code} -tcForeignExports :: Module -> [RenamedHsDecl] - -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl]) -tcForeignExports mod decls = - foldlTc combine (emptyLIE, EmptyMonoBinds, []) - [foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] +tcForeignExports :: [ForeignDecl Name] + -> TcM (TcMonoBinds, [TcForeignDecl]) +tcForeignExports decls + = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls) where - combine (lie, binds, fs) fe = - tcFExport mod fe `thenTc ` \ (a_lie, b, f) -> - returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs) + combine (binds, fs) fe = + tcFExport fe `thenM ` \ (b, f) -> + returnM (b `AndMonoBinds` binds, f:fs) -tcFExport :: Module -> RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl) -tcFExport mod fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = - tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ +tcFExport :: RenamedForeignDecl -> TcM (TcMonoBinds, TcForeignDecl) +tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = + addSrcLoc src_loc $ + addErrCtxt (foreignDeclCtxt fo) $ - tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty -> - tcExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie) -> + tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> + tcCheckSigma (HsVar nm) sig_ty `thenM` \ rhs -> - tcCheckFEType sig_ty spec `thenTc_` + tcCheckFEType sig_ty spec `thenM_` -- we're exporting a function, but at a type possibly more -- constrained than its declared/inferred type. Hence the need -- to create a local binding which will call the exported function -- at a particular type (and, maybe, overloading). - tcGetUnique `thenNF_Tc` \ uniq -> + newUnique `thenM` \ uniq -> + getModule `thenM` \ mod -> let gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc id = setIdLocalExported (mkLocalId gnm sig_ty) bind = VarMonoBind id rhs in - returnTc (lie, bind, ForeignExport id undefined spec isDeprec src_loc) + returnM (bind, ForeignExport id undefined spec isDeprec src_loc) \end{code} ------------ Checking argument types for foreign export ---------------------- \begin{code} tcCheckFEType sig_ty (CExport (CExportStatic str _)) - = check (isCLabelString str) (badCName str) `thenNF_Tc_` - checkForeignArgs isFFIExternalTy arg_tys `thenNF_Tc_` + = check (isCLabelString str) (badCName str) `thenM_` + checkForeignArgs isFFIExternalTy arg_tys `thenM_` checkForeignRes nonIOok isFFIExportResultTy res_ty where -- Drop the foralls before inspecting n @@ -239,22 +240,18 @@ tcCheckFEType sig_ty (CExport (CExportStatic str _)) \begin{code} ------------ Checking argument types for foreign import ---------------------- -checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM () +checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM () checkForeignArgs pred tys - = mapNF_Tc go tys `thenNF_Tc_` - returnNF_Tc () + = mappM go tys `thenM_` + returnM () where - go ty = check (pred ty) (illegalForeignTyErr argument ty) `thenNF_Tc_` - warnTc (isForeignPtrTy ty) foreignPtrWarn - -- - foreignPtrWarn = - text "`ForeignPtr' as argument type in a foreign import is deprecated" + go ty = check (pred ty) (illegalForeignTyErr argument ty) ------------ Checking result types for foreign calls ---------------------- -- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- -checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM () +checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () nonIOok = True mustBeIO = False @@ -263,13 +260,13 @@ checkForeignRes non_io_result_ok pred_res_ty ty = case tcSplitTyConApp_maybe ty of Just (io, [res_ty]) | io `hasKey` ioTyConKey && pred_res_ty res_ty - -> returnNF_Tc () + -> returnM () _ -> check (non_io_result_ok && pred_res_ty ty) (illegalForeignTyErr result ty) \end{code} -\begin{code} +\begin{code} checkDotNet HscILX = Nothing checkDotNet other = Just (text "requires .NET code generation (-filx)") @@ -301,21 +298,21 @@ checkCOrAsmOrDotNetOrInterp other = Just (text "requires interpreted, C, native or .NET ILX code generation") checkCg check - = getDOptsTc `thenNF_Tc` \ dflags -> + = getDOpts `thenM` \ dflags -> let hscLang = dopt_HscLang dflags in case hscLang of - HscNothing -> returnNF_Tc () + HscNothing -> returnM () otherwise -> case check hscLang of - Nothing -> returnNF_Tc () + Nothing -> returnM () Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} Warnings \begin{code} -check :: Bool -> Message -> NF_TcM () -check True _ = returnTc () +check :: Bool -> Message -> TcM () +check True _ = returnM () check _ the_err = addErrTc the_err illegalForeignTyErr arg_or_res ty