X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=e814e06386ca49b3bc8fedd9415de7813740726b;hb=6f122ef3930b51bca54bb96858fe9b8f1d85c461;hp=3b70db5a1653064b52546b240e55d5ba445dbd6f;hpb=18976e614fd90a8d81ced2c3e9cd8e38d72a1f40;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 3b70db5..e814e06 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -20,14 +20,14 @@ module TcForeign #include "HsVersions.h" import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), - ExtName(..), isDynamic, MonoBinds(..), + ExtName(Dynamic), isDynamicExtName, MonoBinds(..), OutPat(..), ForKind(..) ) import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) import TcMonad import TcEnv ( newLocalId ) -import TcType ( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType ) +import TcType ( typeToTcType, tcSplitRhoTy, zonkTcTypeToType ) import TcMonoType ( tcHsTopBoxedType ) import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl ) @@ -36,16 +36,13 @@ import Inst ( emptyLIE, LIE, plusLIE ) import CoreSyn import ErrUtils ( Message ) -import Id ( Id, idName, mkUserId ) +import Id ( Id, idName, mkVanillaId ) import Name ( nameOccName ) import Type ( splitFunTys , splitTyConApp_maybe , splitForAllTys - , splitRhoTy - , isForAllTy - , mkForAllTys ) - +import PprType ( {- instance Outputable Type -} ) import TysWiredIn ( isFFIArgumentTy, isFFIResultTy, isFFIExternalTy, isAddrTy ) @@ -82,7 +79,7 @@ isForeignImport (ForeignDecl _ k _ dyn _ _) = -- exports a binding isForeignExport :: ForeignDecl name -> Bool -isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm) +isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamicExtName ext_nm) isForeignExport _ = False \end{code} @@ -101,7 +98,7 @@ 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 = (mkUserId nm sig_ty) in + 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) = @@ -114,10 +111,10 @@ tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) = (_, t_ty) = splitForAllTys sig_ty in check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_` - let i = (mkUserId nm sig_ty) in + 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) $ @@ -131,8 +128,8 @@ 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, TcMonoBinds, TcForeignExportDecl) @@ -168,62 +165,62 @@ 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 s () +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 + mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs `thenTc_` + checkForeignRes True {-NonIO ok-} isFFIResultTy res | otherwise = - mapTc (checkForeignArg isFFIArgumentTy) args `thenTc_` - checkForeignRes (isFFIResultTy) res + mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_` + checkForeignRes True {-NonIO ok-} isFFIResultTy res checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s () 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 an Addr or 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-} isFFIResultTy res_ty `thenTc_` + checkForeignRes False {-Must be IO-} isAddrTy res _ -> check False (illegalForeignTyErr True{-Arg-} ty) | otherwise = mapTc (checkForeignArg isFFIExternalTy) args `thenTc_` - checkForeignRes (isFFIResultTy) res + checkForeignRes True {-NonIO ok-} isFFIResultTy 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 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 :: (Type -> Bool) -> Type -> TcM s () -checkForeignRes pred_res_ty ty = +checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s () +checkForeignRes non_io_result_ok pred_res_ty ty = case (splitTyConApp_maybe ty) of Just (io, [res_ty]) | (getUnique io) == ioTyConKey && pred_res_ty res_ty -> returnTc () _ - | pred_res_ty ty -> returnTc () - | otherwise -> 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 s () +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 [ppr ty]) @@ -235,5 +232,4 @@ illegalForeignTyErr isArg ty foreignDeclCtxt fo = hang (ptext SLIT("When checking declaration:")) 4 (ppr fo) - \end{code}