X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=b394eefa45147cadadec990e093cb1073d4f2074;hb=73b92b542bb06d33cffd0f548603dd0a4872294a;hp=883103dbe7e89118535a20ab7f852cf3eedcc85a;hpb=1da7b45d4cf8c70dae8525a00eb2cd68160cf813;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 883103d..b394eef 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -21,42 +21,42 @@ module TcForeign import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), ExtName(Dynamic), isDynamicExtName, MonoBinds(..), - OutPat(..), ForKind(..) + ForKind(..) ) import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) import TcMonad import TcEnv ( newLocalId ) -import TcType ( tcSplitRhoTy, zonkTcTypeToType ) -import TcMonoType ( tcHsSigType, tcHsBoxedSigType ) +import TcMonoType ( tcHsLiftedSigType ) import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl ) -import TcExpr ( tcId, tcPolyExpr ) +import TcExpr ( tcPolyExpr ) import Inst ( emptyLIE, LIE, plusLIE ) import ErrUtils ( Message ) -import Id ( Id, idName, mkVanillaId ) +import Id ( Id, mkLocalId ) import Name ( nameOccName ) import Type ( splitFunTys , splitTyConApp_maybe , splitForAllTys ) -import TysWiredIn ( isFFIArgumentTy, isFFIResultTy, - isFFIExternalTy, isAddrTy, - isFFIDynResultTy, isFFILabelTy +import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy, + isFFIExportResultTy, + isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy, + isFFILabelTy ) import Type ( Type ) -import Unique +import PrelNames ( hasKey, ioTyConKey ) import Outputable \end{code} \begin{code} -tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl]) +tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl]) tcForeignImports decls = mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] -tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE, TcMonoBinds, [TcForeignExportDecl]) +tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl]) tcForeignExports decls = foldlTc combine (emptyLIE, EmptyMonoBinds, []) [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] @@ -81,11 +81,11 @@ isForeignExport _ = False \end{code} \begin{code} -tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl) +tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsBoxedSigType hs_ty `thenTc` \ sig_ty -> + tcHsLiftedSigType hs_ty `thenTc` \ sig_ty -> let -- drop the foralls before inspecting the structure -- of the foreign type. @@ -94,13 +94,13 @@ tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) = case splitFunTys t_ty of (arg_tys, res_ty) -> checkForeignExport True t_ty arg_tys res_ty `thenTc_` - let i = (mkVanillaId nm sig_ty) in + let i = (mkLocalId nm sig_ty) in returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc)) tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsBoxedSigType hs_ty `thenTc` \ sig_ty -> + tcHsLiftedSigType hs_ty `thenTc` \ sig_ty -> let -- drop the foralls before inspecting the structure -- of the foreign type. @@ -108,14 +108,14 @@ tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) = in check (isFFILabelTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_` - let i = (mkVanillaId nm sig_ty) in + let i = (mkLocalId nm sig_ty) in returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc)) tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsSigType hs_ty `thenTc` \ ty -> + tcHsLiftedSigType hs_ty `thenTc` \ ty -> -- Check that the type has the right shape -- and that the argument and result types are acceptable. let @@ -126,15 +126,15 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_ case splitFunTys t_ty of (arg_tys, res_ty) -> checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_` - let i = (mkVanillaId nm ty) in + let i = (mkLocalId nm ty) in returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc)) -tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl) +tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl) tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsBoxedSigType hs_ty `thenTc` \ sig_ty -> + tcHsLiftedSigType hs_ty `thenTc` \ sig_ty -> tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) -> let @@ -161,45 +161,48 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = \begin{code} -checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM s () +checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM () checkForeignImport is_dynamic is_safe ty args res | is_dynamic = -- * first arg has got to be an Addr case args of [] -> check False (illegalForeignTyErr True{-Arg-} ty) (x:xs) -> - check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_` - mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs `thenTc_` - checkForeignRes True {-NonIO ok-} isFFIResultTy res + getDOptsTc `thenTc` \ dflags -> + check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_` + mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs `thenTc_` + checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res | otherwise = - mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_` - checkForeignRes True {-NonIO ok-} isFFIResultTy res + getDOptsTc `thenTc` \ dflags -> + mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_` + checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res -checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s () +checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM () checkForeignExport is_dynamic ty args res | is_dynamic = -- * the first (and only!) arg has got to be a function type -- and it must return IO t - -- * result type is an Addr or IO Addr + -- * result type is IO Addr case args of [arg] -> case splitFunTys arg of (arg_tys, res_ty) -> mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_` - checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_` + checkForeignRes True {-NonIO ok-} isFFIExportResultTy res_ty + `thenTc_` checkForeignRes False {-Must be IO-} isFFIDynResultTy res _ -> check False (illegalForeignTyErr True{-Arg-} ty) | otherwise = mapTc (checkForeignArg isFFIExternalTy) args `thenTc_` - checkForeignRes True {-NonIO ok-} isFFIResultTy res + checkForeignRes True {-NonIO ok-} isFFIExportResultTy res -checkForeignArg :: (Type -> Bool) -> Type -> TcM s () +checkForeignArg :: (Type -> Bool) -> Type -> TcM () checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty) -- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- -checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s () +checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () checkForeignRes non_io_result_ok pred_res_ty ty = case (splitTyConApp_maybe ty) of Just (io, [res_ty]) @@ -213,7 +216,7 @@ checkForeignRes non_io_result_ok pred_res_ty ty = Warnings \begin{code} -check :: Bool -> Message -> TcM s () +check :: Bool -> Message -> TcM () check True _ = returnTc () check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()