X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=345011bb23e464240081eae311a90502bfc36010;hb=c4f3290f3d4c2a5c2e81a97717f7fd06ee180f6d;hp=81be93e90c956f5f1ad98615e047bff84b296bf3;hpb=a26cca812ccc549e2e8e6112c60cb7fddfbd4f9c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 81be93e..345011b 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -7,65 +7,59 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} -#include "HsVersions.h" - module TcHsSyn ( - SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcPat), - SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch), - SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds), - SYN_IE(TcHsModule), SYN_IE(TcCoreExpr), SYN_IE(TcDictBinds), + TcMonoBinds, TcHsBinds, TcPat, + TcExpr, TcGRHSsAndBinds, TcGRHS, TcMatch, + TcStmt, TcArithSeqInfo, TcRecordBinds, + TcHsModule, TcCoreExpr, TcDictBinds, - SYN_IE(TypecheckedHsBinds), - SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat), - SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo), - SYN_IE(TypecheckedStmt), - SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule), - SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), - SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedDictBinds), + TypecheckedHsBinds, + TypecheckedMonoBinds, TypecheckedPat, + TypecheckedHsExpr, TypecheckedArithSeqInfo, + TypecheckedStmt, + TypecheckedMatch, TypecheckedHsModule, + TypecheckedGRHSsAndBinds, TypecheckedGRHS, + TypecheckedRecordBinds, TypecheckedDictBinds, mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, - tcIdType, tcIdTyVars, - zonkTopBinds, zonkBinds, zonkMonoBinds + -- re-exported from TcEnv + TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId, + + maybeBoxedPrimType, + + zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -- friends: import HsSyn -- oodles of it -import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids - SYN_IE(DictVar), idType, - SYN_IE(Id) +import Id ( idType, dataConArgTys, mkIdWithNewType, Id ) -- others: -import Name ( Name{--O only-}, NamedThing(..) ) -import BasicTypes ( IfaceFlavour ) -import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv ) +import Name ( NamedThing(..) ) +import BasicTypes ( IfaceFlavour, Unused ) +import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, tcGetGlobalValEnv, + TcIdOcc(..), TcIdBndr, GlobalValueEnv, + tcIdType, tcIdTyVars, tcInstId + ) + import TcMonad -import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), - zonkTcTypeToType, zonkTcTyVarToTyVar +import TcType ( TcType, TcMaybe, TcTyVar, TcBox, + zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType ) -import Usage ( SYN_IE(UVar) ) -import Util ( zipEqual, panic, - pprPanic, pprTrace -#ifdef DEBUG - , assertPanic -#endif - ) - -import PprType ( GenType, GenTyVar ) -- instances -import Type ( mkTyVarTy, tyVarsOfType, SYN_IE(Type) ) -import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar), - SYN_IE(TyVarEnv), nullTyVarEnv, growTyVarEnvList, emptyTyVarSet ) +import TyCon ( isDataTyCon ) +import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnpointedType, Type ) +import TyVar ( TyVar, TyVarEnv, emptyTyVarEnv, growTyVarEnvList ) import TysPrim ( voidTy ) import CoreSyn ( GenCoreExpr ) import Unique ( Unique ) -- instances import Bag import UniqFM import Outputable -import Pretty \end{code} @@ -80,33 +74,33 @@ At the end of type checking we zonk everything to @Typechecked...@ datatypes, which have immutable type variables in them. \begin{code} -type TcHsBinds s = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) +type TcHsBinds s = HsBinds (TcBox s) (TcIdOcc s) (TcPat s) +type TcMonoBinds s = MonoBinds (TcBox s) (TcIdOcc s) (TcPat s) type TcDictBinds s = TcMonoBinds s -type TcPat s = OutPat (TcTyVar s) UVar (TcIdOcc s) -type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s) - -type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcTyVar s) UVar - -type TypecheckedPat = OutPat TyVar UVar Id -type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat +type TcPat s = OutPat (TcBox s) (TcIdOcc s) +type TcExpr s = HsExpr (TcBox s) (TcIdOcc s) (TcPat s) +type TcGRHSsAndBinds s = GRHSsAndBinds (TcBox s) (TcIdOcc s) (TcPat s) +type TcGRHS s = GRHS (TcBox s) (TcIdOcc s) (TcPat s) +type TcMatch s = Match (TcBox s) (TcIdOcc s) (TcPat s) +type TcStmt s = Stmt (TcBox s) (TcIdOcc s) (TcPat s) +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 TypecheckedPat = OutPat Unused Id +type TypecheckedMonoBinds = MonoBinds Unused Id TypecheckedPat type TypecheckedDictBinds = TypecheckedMonoBinds -type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat -type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat -type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat -type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat -type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat -type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat -type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat -type TypecheckedRecordBinds = HsRecordBinds TyVar UVar Id TypecheckedPat -type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat +type TypecheckedHsBinds = HsBinds Unused Id TypecheckedPat +type TypecheckedHsExpr = HsExpr Unused Id TypecheckedPat +type TypecheckedArithSeqInfo = ArithSeqInfo Unused Id TypecheckedPat +type TypecheckedStmt = Stmt Unused Id TypecheckedPat +type TypecheckedMatch = Match Unused Id TypecheckedPat +type TypecheckedGRHSsAndBinds = GRHSsAndBinds Unused Id TypecheckedPat +type TypecheckedGRHS = GRHS Unused Id TypecheckedPat +type TypecheckedRecordBinds = HsRecordBinds Unused Id TypecheckedPat +type TypecheckedHsModule = HsModule Unused Id TypecheckedPat \end{code} \begin{code} @@ -121,13 +115,29 @@ mkHsTyLam tyvars expr = TyLam tyvars expr mkHsDictLam [] expr = expr mkHsDictLam dicts expr = DictLam dicts expr +\end{code} -tcIdType :: TcIdOcc s -> TcType s -tcIdType (TcId id) = idType id -tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id) +%************************************************************************ +%* * +\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} +%* * +%************************************************************************ + +Some gruesome hackery for desugaring ccalls. It's here because if we put it +in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and +DsCCall.lhs. -tcIdTyVars (TcId id) = tyVarsOfType (idType id) -tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables +\begin{code} +maybeBoxedPrimType :: Type -> Maybe (Id, Type) +maybeBoxedPrimType ty + = case splitAlgTyConApp_maybe ty of -- Data type, + Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor + -> case (dataConArgTys data_con tys_applied) of + [data_con_arg_ty] -- Applied to exactly one type, + | isUnpointedType data_con_arg_ty -- which is primitive + -> Just (data_con, data_con_arg_ty) + other_cases -> Nothing + other_cases -> Nothing \end{code} %************************************************************************ @@ -136,6 +146,16 @@ tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variab %* * %************************************************************************ +@zonkTcId@ just works on TcIdOccs. It's used when zonking Method insts. + +\begin{code} +zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s) +zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id +zonkTcId (TcId id) + = zonkTcType (idType id) `thenNF_Tc` \ ty' -> + returnNF_Tc (TcId (mkIdWithNewType id ty')) +\end{code} + This zonking pass runs over the bindings a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc @@ -155,16 +175,15 @@ were previously in the LVE of the Tc monad.) It's all pretty boring stuff, because HsSyn is such a large type, and the environment manipulation is tiresome. - \begin{code} extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars] zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id -zonkIdBndr te (TcId (Id u n ty details prags info)) - = zonkTcTypeToType te ty `thenNF_Tc` \ ty' -> - returnNF_Tc (Id u n ty' details prags info) - zonkIdBndr te (RealId id) = returnNF_Tc id +zonkIdBndr te (TcId id) + = zonkTcTypeToType te (idType id) `thenNF_Tc` \ ty' -> + returnNF_Tc (mkIdWithNewType id ty') + zonkIdOcc :: TcIdOcc s -> NF_TcM s Id zonkIdOcc (RealId id) = returnNF_Tc id @@ -173,22 +192,20 @@ zonkIdOcc (TcId id) let new_id = case maybe_id' of Just id' -> id' - Nothing -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $ - Id u n voidTy details prags info - where - Id u n _ details prags info = id + Nothing -> pprTrace "zonkIdOcc: " (ppr id) $ + mkIdWithNewType id voidTy in returnNF_Tc new_id \end{code} \begin{code} -zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s) +zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, GlobalValueEnv) zonkTopBinds binds -- Top level is implicitly recursive = fixNF_Tc (\ ~(_, new_ids) -> tcExtendGlobalValEnv (bagToList new_ids) $ - zonkMonoBinds nullTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) -> - tcGetEnv `thenNF_Tc` \ env -> + zonkMonoBinds emptyTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) -> + tcGetGlobalValEnv `thenNF_Tc` \ env -> returnNF_Tc ((binds', env), new_ids) ) `thenNF_Tc` \ (stuff, _) -> returnNF_Tc stuff @@ -318,10 +335,6 @@ zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty) tcSetEnv new_env $ zonkExpr te expr `thenNF_Tc` \ new_expr -> returnNF_Tc (GRHS new_guard new_expr locn) - - zonk_grhs (OtherwiseGRHS expr locn) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (OtherwiseGRHS new_expr locn) in mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> @@ -415,10 +428,16 @@ zonkExpr te (ExplicitTuple exprs) = mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitTuple new_exprs) -zonkExpr te (RecordCon con rbinds) - = zonkExpr te con `thenNF_Tc` \ new_con -> +zonkExpr te (HsCon con_id tys exprs) + = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys -> + mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (HsCon con_id new_tys new_exprs) + +zonkExpr te (RecordCon con_id con_expr rbinds) + = zonkIdOcc con_id `thenNF_Tc` \ new_con_id -> + zonkExpr te con_expr `thenNF_Tc` \ new_con_expr -> zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordCon new_con new_rbinds) + returnNF_Tc (RecordCon new_con_id new_con_expr new_rbinds) zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd" @@ -470,20 +489,6 @@ zonkExpr te (DictApp expr dicts) mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> returnNF_Tc (DictApp new_expr new_dicts) -zonkExpr te (ClassDictLam dicts methods expr) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods -> - returnNF_Tc (ClassDictLam new_dicts new_methods new_expr) - -zonkExpr te (Dictionary dicts methods) - = mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods -> - returnNF_Tc (Dictionary new_dicts new_methods) - -zonkExpr te (SingleDict name) - = zonkIdOcc name `thenNF_Tc` \ name' -> - returnNF_Tc (SingleDict name') -------------------------------------------------------------------------