X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=875d9747086212110d5f7bd82c2baf982153a1a4;hb=9c848a68f7b05aa352cd97d9a75488d20a774736;hp=4a2e4a21add4aae802b5f1f027b07ca57f455216;hpb=14ac360a0651770f9297134e55bf5ba796689035;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 4a2e4a2..875d974 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -20,55 +20,43 @@ module TcForeign #include "HsVersions.h" import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), - ExtName(..), isDynamic, MonoBinds(..), - OutPat(..) + ExtName(Dynamic), isDynamicExtName, MonoBinds(..), + ForKind(..) ) import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) import TcMonad -import TcEnv ( tcLookupClassByKey, newLocalId, tcLookupGlobalValue ) -import TcType ( tcInstTcType, tcInstSigType, tcSplitRhoTy, zonkTcTypeToType ) -import TcMonoType ( tcHsType ) -import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl, TcIdOcc(..), +import TcEnv ( newLocalId ) +import TcMonoType ( tcHsLiftedSigType ) +import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl ) -import TcExpr ( tcId, tcPolyExpr ) +import TcExpr ( tcPolyExpr ) import Inst ( emptyLIE, LIE, plusLIE ) -import CoreSyn import ErrUtils ( Message ) -import Id ( Id, idName ) +import Id ( Id, mkVanillaId ) import Name ( nameOccName ) -import MkId ( mkUserId ) -import Type ( isUnpointedType - , splitFunTys +import Type ( splitFunTys , splitTyConApp_maybe , splitForAllTys - , splitRhoTy - , isForAllTy - , mkForAllTys ) -import TyVar ( emptyTyVarEnv ) - - -import TysWiredIn ( isFFIArgumentTy, isFFIResultTy, - isFFIExternalTy, isAddrTy +import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy, + isFFIExportResultTy, + isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy, + isFFILabelTy ) import Type ( Type ) -import Unique -import Unify ( unifyTauTy ) +import PrelNames ( hasKey, ioTyConKey ) import Outputable -import Util -import CmdLineOpts ( opt_GlasgowExts ) -import Maybes ( maybeToBool ) \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 s, TcMonoBinds s, [TcForeignExportDecl s]) +tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl]) tcForeignExports decls = foldlTc combine (emptyLIE, EmptyMonoBinds, []) [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] @@ -79,23 +67,25 @@ tcForeignExports decls = -- defines a binding isForeignImport :: ForeignDecl name -> Bool -isForeignImport (ForeignDecl _ (Just _) _ _ _ _) = True -isForeignImport (ForeignDecl _ Nothing _ Dynamic _ _) = True -isForeignImport _ = False +isForeignImport (ForeignDecl _ k _ dyn _ _) = + case k of + FoImport _ -> True + FoExport -> case dyn of { Dynamic -> True ; _ -> False } + FoLabel -> True -- exports a binding isForeignExport :: ForeignDecl name -> Bool -isForeignExport (ForeignDecl _ Nothing _ ext_nm _ _) = not (isDynamic ext_nm) -isForeignExport _ = False +isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamicExtName ext_nm) +isForeignExport _ = False \end{code} \begin{code} -tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl) -tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) = +tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) +tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsType hs_ty `thenTc` \ sig_ty -> + tcHsLiftedSigType hs_ty `thenTc` \ sig_ty -> let -- drop the foralls before inspecting the structure -- of the foreign type. @@ -104,14 +94,28 @@ tcFImport fo@(ForeignDecl nm Nothing 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 = (mkUserId nm sig_ty) in - returnTc (i, (ForeignDecl i Nothing undefined Dynamic cconv src_loc)) + let i = (mkVanillaId 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) $ + tcHsLiftedSigType hs_ty `thenTc` \ sig_ty -> + let + -- drop the foralls before inspecting the structure + -- of the foreign type. + (_, t_ty) = splitForAllTys sig_ty + in + 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)) -tcFImport fo@(ForeignDecl nm imp_exp hs_ty 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) $ - tcHsType 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 @@ -121,18 +125,17 @@ tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = in case splitFunTys t_ty of (arg_tys, res_ty) -> - checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_` - let i = (mkUserId nm ty) in + checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_` + let i = (mkVanillaId nm ty) in returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc)) -tcFExport :: RenamedForeignDecl -> TcM s (LIE s, TcMonoBinds s, TcForeignExportDecl s) +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) $ - tcHsType hs_ty `thenTc` \ sig_ty -> - tcInstSigType sig_ty `thenNF_Tc` \ sig_tc_ty -> - tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) -> + tcHsLiftedSigType hs_ty `thenTc` \ sig_ty -> + tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) -> let -- drop the foralls before inspecting the structure @@ -146,12 +149,11 @@ 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 `thenNF_Tc` \ i -> + newLocalId (nameOccName nm) sig_ty src_loc `thenNF_Tc` \ i -> let - i2 = TcId i - bind = VarMonoBind i2 rhs + bind = VarMonoBind i rhs in - returnTc (lie, bind, ForeignDecl i2 imp_exp undefined ext_nm cconv src_loc) + returnTc (lie, bind, ForeignDecl i imp_exp undefined ext_nm cconv src_loc) -- ^^^^^^^^^ -- ToDo: fill the type field in with something sensible. @@ -159,71 +161,74 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = \begin{code} -checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s () -checkForeignImport is_dynamic ty args res +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) xs `thenTc_` - checkForeignRes (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) args `thenTc_` - checkForeignRes (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 - -- * result type is an Addr + -- and it must return IO t + -- * result type is IO Addr case args of [arg] -> case splitFunTys arg of (arg_tys, res_ty) -> - mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_` - checkForeignRes (isFFIResultTy) res_ty `thenTc_` - checkForeignRes (isAddrTy) res + mapTc (checkForeignArg isFFIExternalTy) arg_tys `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 (isFFIResultTy) res + checkForeignRes True {-NonIO ok-} isFFIExportResultTy res -check :: Bool -> Message -> TcM s () -check True _ = returnTc () -check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc () - -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) and that t satisfies the given predicate. +-- (IO t) or (t) , and that t satisfies the given predicate. -- -checkForeignRes :: (Type -> Bool) -> Type -> TcM s () -checkForeignRes pred_res_ty ty = +checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () +checkForeignRes non_io_result_ok pred_res_ty ty = case (splitTyConApp_maybe ty) of Just (io, [res_ty]) - | (uniqueOf io) == ioTyConKey && - pred_res_ty res_ty + | io `hasKey` ioTyConKey && pred_res_ty res_ty -> returnTc () - _ -> check False (illegalForeignTyErr False{-Res-} ty) - + _ + -> check (non_io_result_ok && pred_res_ty ty) + (illegalForeignTyErr False{-Res-} ty) \end{code} Warnings \begin{code} +check :: Bool -> Message -> TcM () +check True _ = returnTc () +check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc () + illegalForeignTyErr isArg ty - = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration")]) - 4 (hsep [ ptext SLIT("type:"), ppr ty]) + = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")]) + 4 (hsep [ppr ty]) where arg_or_res | isArg = ptext SLIT("argument") | otherwise = ptext SLIT("result") foreignDeclCtxt fo = - hang (ptext SLIT("When checking a foreign declaration:")) + hang (ptext SLIT("When checking declaration:")) 4 (ppr fo) - \end{code}