From 14ac360a0651770f9297134e55bf5ba796689035 Mon Sep 17 00:00:00 2001 From: sof Date: Fri, 14 Aug 1998 12:08:32 +0000 Subject: [PATCH] [project @ 1998-08-14 12:08:25 by sof] Typecheck foreign declarations --- ghc/compiler/typecheck/TcForeign.lhs | 229 +++++++++++++++++++++++++++++++++ ghc/compiler/typecheck/TcHsSyn.lhs | 26 +++- ghc/compiler/typecheck/TcIfaceSig.lhs | 3 +- ghc/compiler/typecheck/TcModule.lhs | 40 ++++-- 4 files changed, 281 insertions(+), 17 deletions(-) create mode 100644 ghc/compiler/typecheck/TcForeign.lhs diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs new file mode 100644 index 0000000..4a2e4a2 --- /dev/null +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -0,0 +1,229 @@ +% +% (c) The AQUA Project, Glasgow University, 1998 +% +\section[TcForeign]{Typechecking \tr{foreign} declarations} + +A foreign declaration is used to either give an externally +implemented function a Haskell type (and calling interface) or +give a Haskell function an external calling interface. Either way, +the range of argument and result types these functions can accommodate +is restricted to what the outside world understands (read C), and this +module checks to see if a foreign declaration has got a legal type. + +\begin{code} +module TcForeign + ( + tcForeignImports + , tcForeignExports + ) where + +#include "HsVersions.h" + +import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), + ExtName(..), isDynamic, MonoBinds(..), + OutPat(..) + ) +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(..), + TcForeignExportDecl ) +import TcExpr ( tcId, tcPolyExpr ) +import Inst ( emptyLIE, LIE, plusLIE ) +import CoreSyn + +import ErrUtils ( Message ) +import Id ( Id, idName ) +import Name ( nameOccName ) +import MkId ( mkUserId ) +import Type ( isUnpointedType + , splitFunTys + , splitTyConApp_maybe + , splitForAllTys + , splitRhoTy + , isForAllTy + , mkForAllTys + ) +import TyVar ( emptyTyVarEnv ) + + +import TysWiredIn ( isFFIArgumentTy, isFFIResultTy, + isFFIExternalTy, isAddrTy + ) +import Type ( Type ) +import Unique +import Unify ( unifyTauTy ) +import Outputable +import Util +import CmdLineOpts ( opt_GlasgowExts ) +import Maybes ( maybeToBool ) + +\end{code} + +\begin{code} +tcForeignImports :: [RenamedHsDecl] -> TcM s ([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 decls = + foldlTc combine (emptyLIE, EmptyMonoBinds, []) + [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] + where + combine (lie, binds, fs) fe = + tcFExport fe `thenTc ` \ (a_lie, b, f) -> + returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs) + +-- defines a binding +isForeignImport :: ForeignDecl name -> Bool +isForeignImport (ForeignDecl _ (Just _) _ _ _ _) = True +isForeignImport (ForeignDecl _ Nothing _ Dynamic _ _) = True +isForeignImport _ = False + +-- exports a binding +isForeignExport :: ForeignDecl name -> Bool +isForeignExport (ForeignDecl _ Nothing _ ext_nm _ _) = not (isDynamic 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) = + tcAddSrcLoc src_loc $ + tcAddErrCtxt (foreignDeclCtxt fo) $ + tcHsType hs_ty `thenTc` \ sig_ty -> + let + -- drop the foralls before inspecting the structure + -- of the foreign type. + (_, t_ty) = splitForAllTys sig_ty + in + 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)) + +tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = + tcAddSrcLoc src_loc $ + tcAddErrCtxt (foreignDeclCtxt fo) $ + + tcHsType hs_ty `thenTc` \ ty -> + -- Check that the type has the right shape + -- and that the argument and result types are acceptable. + let + -- drop the foralls before inspecting the structure + -- of the foreign type. + (_, t_ty) = splitForAllTys ty + 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 + returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc)) + +tcFExport :: RenamedForeignDecl -> TcM s (LIE s, TcMonoBinds s, TcForeignExportDecl s) +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, _, _, _) -> + + let + -- drop the foralls before inspecting the structure + -- of the foreign type. + (_, t_ty) = splitForAllTys sig_ty + in + case splitFunTys t_ty of + (arg_tys, res_ty) -> + checkForeignExport False t_ty arg_tys res_ty `thenTc_` + -- 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). + newLocalId (nameOccName nm) sig_tc_ty `thenNF_Tc` \ i -> + let + i2 = TcId i + bind = VarMonoBind i2 rhs + in + returnTc (lie, bind, ForeignDecl i2 imp_exp undefined ext_nm cconv src_loc) + -- ^^^^^^^^^ + -- ToDo: fill the type field in with something sensible. + +\end{code} + + +\begin{code} +checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s () +checkForeignImport is_dynamic 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 + | otherwise = + mapTc (checkForeignArg isFFIArgumentTy) args `thenTc_` + checkForeignRes (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 + 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 + _ -> check False (illegalForeignTyErr True{-Arg-} ty) + | otherwise = + mapTc (checkForeignArg isFFIExternalTy) args `thenTc_` + checkForeignRes (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) and that t satisfies the given predicate. +-- +checkForeignRes :: (Type -> Bool) -> Type -> TcM s () +checkForeignRes pred_res_ty ty = + case (splitTyConApp_maybe ty) of + Just (io, [res_ty]) + | (uniqueOf io) == ioTyConKey && + pred_res_ty res_ty + -> returnTc () + _ -> check False (illegalForeignTyErr False{-Res-} ty) + +\end{code} + +Warnings + +\begin{code} +illegalForeignTyErr isArg ty + = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration")]) + 4 (hsep [ ptext SLIT("type:"), ppr ty]) + where + arg_or_res + | isArg = ptext SLIT("argument") + | otherwise = ptext SLIT("result") + +foreignDeclCtxt fo = + hang (ptext SLIT("When checking a foreign declaration:")) + 4 (ppr fo) + +\end{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 345011b..64275c0 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -12,11 +12,12 @@ module TcHsSyn ( TcExpr, TcGRHSsAndBinds, TcGRHS, TcMatch, TcStmt, TcArithSeqInfo, TcRecordBinds, TcHsModule, TcCoreExpr, TcDictBinds, + TcForeignExportDecl, TypecheckedHsBinds, TypecheckedMonoBinds, TypecheckedPat, TypecheckedHsExpr, TypecheckedArithSeqInfo, - TypecheckedStmt, + TypecheckedStmt, TypecheckedForeignDecl, TypecheckedMatch, TypecheckedHsModule, TypecheckedGRHSsAndBinds, TypecheckedGRHS, TypecheckedRecordBinds, TypecheckedDictBinds, @@ -29,7 +30,8 @@ module TcHsSyn ( maybeBoxedPrimType, - zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId + zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId, + zonkForeignExports ) where #include "HsVersions.h" @@ -87,7 +89,8 @@ type TcArithSeqInfo s = ArithSeqInfo (TcBox s) (TcIdOcc s) (TcPat s) type TcRecordBinds s = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s) type TcHsModule s = HsModule (TcBox s) (TcIdOcc s) (TcPat s) -type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s) +type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s) +type TcForeignExportDecl s = ForeignDecl (TcIdOcc s) type TypecheckedPat = OutPat Unused Id type TypecheckedMonoBinds = MonoBinds Unused Id TypecheckedPat @@ -101,6 +104,7 @@ type TypecheckedGRHSsAndBinds = GRHSsAndBinds Unused Id TypecheckedPat type TypecheckedGRHS = GRHS Unused Id TypecheckedPat type TypecheckedRecordBinds = HsRecordBinds Unused Id TypecheckedPat type TypecheckedHsModule = HsModule Unused Id TypecheckedPat +type TypecheckedForeignDecl = ForeignDecl Id \end{code} \begin{code} @@ -652,4 +656,20 @@ zonkPats te (pat:pats) returnNF_Tc (pat':pats', ids1 `unionBags` ids2) \end{code} +%************************************************************************ +%* * +\subsection[BackSubst-Foreign]{Foreign exports} +%* * +%************************************************************************ + +\begin{code} +zonkForeignExports :: [TcForeignExportDecl s] -> NF_TcM s [TypecheckedForeignDecl] +zonkForeignExports ls = mapNF_Tc zonkForeignExport ls + +zonkForeignExport :: TcForeignExportDecl s -> NF_TcM s (TypecheckedForeignDecl) +zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) = + zonkIdOcc i `thenNF_Tc` \ i' -> + returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc) + +\end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 000386f..d8088bb 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -28,6 +28,7 @@ import CoreUnfold import MagicUFs ( MagicUnfoldingFun ) import WwLib ( mkWrapper ) import PrimOp ( PrimOp(..) ) +import CallConv ( cCallConv ) import MkId ( mkImportedId, mkUserId ) import Id ( Id, addInlinePragma, isPrimitiveId_maybe, dataConArgTys ) @@ -355,7 +356,7 @@ tcCorePrim (UfOtherOp op) tcCorePrim (UfCCallOp str casm gc arg_tys res_ty) = mapTc tcHsType arg_tys `thenTc` \ arg_tys' -> tcHsType res_ty `thenTc` \ res_ty' -> - returnTc (CCallOp str casm gc arg_tys' res_ty') + returnTc (CCallOp (Just str) casm gc cCallConv arg_tys' res_ty') \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index c3767e1..7afa39c 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -15,7 +15,9 @@ module TcModule ( import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_deriv ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) ) import RnHsSyn ( RenamedHsModule ) -import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds ) +import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds, + TypecheckedForeignDecl, zonkForeignExports + ) import TcMonad import Inst ( Inst, emptyLIE, plusLIE ) @@ -24,8 +26,9 @@ import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) import TcEnv ( TcIdOcc(..), tcExtendGlobalValEnv, tcExtendTyConEnv, getEnv_TyCons, getEnv_Classes, tcLookupLocalValue, - tcLookupTyCon, initEnv ) + tcLookupTyCon, initEnv, tcSetGlobalValEnv ) import TcExpr ( tcId ) +import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo ) @@ -65,7 +68,8 @@ Outside-world interface: type TcResults = (TypecheckedMonoBinds, [TyCon], [Class], - Bag InstInfo, -- Instance declaration information + Bag InstInfo, -- Instance declaration information + [TypecheckedForeignDecl], -- foreign import & exports. TcDDumpDeriv) type TcDDumpDeriv = SDoc @@ -87,13 +91,13 @@ typecheckModule us rn_name_supply mod dumpIfSet opt_D_dump_tc "Typechecked" (case maybe_result of - Just (binds, _, _, _, _) -> ppr binds - Nothing -> text "Typecheck failed") >> + Just (binds, _, _, _, ds, _) -> ppr binds $$ ppr ds + Nothing -> text "Typecheck failed") >> dumpIfSet opt_D_dump_deriv "Derived instances" (case maybe_result of - Just (_, _, _, _, dump_deriv) -> dump_deriv - Nothing -> empty) >> + Just (_, _, _, _, _, dump_deriv) -> dump_deriv + Nothing -> empty) >> return (if isEmptyBag errs then maybe_result @@ -193,6 +197,9 @@ tcModule rn_name_supply tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> tcExtendGlobalValEnv sig_ids $ + -- foreign import declarations next. + tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) -> + tcExtendGlobalValEnv fo_ids $ -- Value declarations next. -- We also typecheck any extra binds that came out of the "deriving" process @@ -205,6 +212,8 @@ tcModule rn_name_supply ) `thenTc` \ ((val_binds, final_env), lie_valdecls) -> tcSetEnv final_env $ + -- foreign export declarations next. + tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) -> -- Second pass over class and instance declarations, -- to compile the bindings themselves. @@ -212,8 +221,6 @@ tcModule rn_name_supply tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) -> - - -- Check that "main" has the right signature tcCheckMainSig mod_name `thenTc_` @@ -225,7 +232,10 @@ tcModule rn_name_supply -- during the generalisation step.) -- trace "tc9" $ let - lie_alldecls = lie_valdecls `plusLIE` lie_instdecls `plusLIE` lie_clasdecls + lie_alldecls = lie_valdecls `plusLIE` + lie_instdecls `plusLIE` + lie_clasdecls `plusLIE` + lie_fodecls in tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> @@ -237,12 +247,16 @@ tcModule rn_name_supply val_binds `AndMonoBinds` inst_binds `AndMonoBinds` cls_binds `AndMonoBinds` - const_inst_binds + const_inst_binds `AndMonoBinds` + foe_binds in - zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) -> + zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) -> + tcSetGlobalValEnv really_final_env $ + zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' -> returnTc (really_final_env, - (all_binds', local_tycons, local_classes, inst_info, ddump_deriv)) + (all_binds',local_tycons, local_classes, + inst_info, foi_decls ++ foe_decls', ddump_deriv)) -- End of outer fix loop ) `thenTc` \ (final_env, stuff) -> -- 1.7.10.4