X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=c8d61d20df445308ac253c313907a711fd0b8a4b;hb=12c932dc23931224b3795736ac27c1d3750df00f;hp=7e4140799b175208e5fa1e890c4c7edf4baa3ae0;hpb=ff755dd9a0a0ad2f106c323852553ea247f16141;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 7e41407..c8d61d2 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -21,41 +21,41 @@ 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 ( typeToTcType, tcSplitRhoTy, zonkTcTypeToType ) -import TcMonoType ( tcHsTopBoxedType ) +import TcMonoType ( tcHsBoxedSigType ) 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, mkVanillaId ) import Name ( nameOccName ) import Type ( splitFunTys , splitTyConApp_maybe , splitForAllTys ) import TysWiredIn ( isFFIArgumentTy, isFFIResultTy, - isFFIExternalTy, isAddrTy + 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] @@ -80,11 +80,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) $ - tcHsTopBoxedType hs_ty `thenTc` \ sig_ty -> + tcHsBoxedSigType hs_ty `thenTc` \ sig_ty -> let -- drop the foralls before inspecting the structure -- of the foreign type. @@ -99,13 +99,14 @@ tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) = tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsTopBoxedType hs_ty `thenTc` \ sig_ty -> + tcHsBoxedSigType hs_ty `thenTc` \ sig_ty -> let -- drop the foralls before inspecting the structure -- of the foreign type. (_, t_ty) = splitForAllTys sig_ty in - check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_` + check (isFFILabelTy t_ty) + (illegalForeignTyErr False{-result-} sig_ty) `thenTc_` let i = (mkVanillaId nm sig_ty) in returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc)) @@ -113,7 +114,7 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_ tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsTopBoxedType hs_ty `thenTc` \ ty -> + tcHsBoxedSigType hs_ty `thenTc` \ ty -> -- Check that the type has the right shape -- and that the argument and result types are acceptable. let @@ -127,14 +128,13 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_ let i = (mkVanillaId 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) $ - tcHsTopBoxedType hs_ty `thenTc` \ sig_ty -> - let sig_tc_ty = typeToTcType sig_ty in - tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) -> + tcHsBoxedSigType hs_ty `thenTc` \ sig_ty -> + tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) -> let -- drop the foralls before inspecting the structure @@ -148,7 +148,7 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = -- 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). - newLocalId (nameOccName nm) sig_tc_ty src_loc `thenNF_Tc` \ i -> + newLocalId (nameOccName nm) sig_ty src_loc `thenNF_Tc` \ i -> let bind = VarMonoBind i rhs in @@ -160,45 +160,47 @@ 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_` + getDOptsTc `thenTc` \ dflags -> + check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_` + mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs `thenTc_` checkForeignRes True {-NonIO ok-} isFFIResultTy res | otherwise = - mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_` + getDOptsTc `thenTc` \ dflags -> + mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_` checkForeignRes True {-NonIO ok-} isFFIResultTy 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 False {-Must be IO-} isAddrTy res + mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_` + checkForeignRes True {-NonIO ok-} isFFIResultTy 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 -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]) @@ -212,7 +214,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 ()