X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=2d84b670ecd260c5e9a0b191ca0df22f550cc0cc;hb=a202c6c4a455b7db2c5846553edf4d55145b9a3a;hp=051d6cd27c5c7c1d5fe6705d1816b8a54dc4efd4;hpb=4250d64191132fd493985549eda5ca05b82a663f;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 051d6cd..2d84b67 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker} @@ -8,51 +8,58 @@ checker. \begin{code} module TcHsSyn ( - TcIdBndr(..), TcIdOcc(..), + TcMonoBinds, TcHsBinds, TcPat, + TcExpr, TcGRHSs, TcGRHS, TcMatch, + TcStmt, TcArithSeqInfo, TcRecordBinds, + TcHsModule, TcCoreExpr, TcDictBinds, + TcForeignExportDecl, - TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..), - TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..), - TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..), - TcHsModule(..), - - TypecheckedHsBinds(..), TypecheckedBind(..), - TypecheckedMonoBinds(..), TypecheckedPat(..), - TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..), - TypecheckedQual(..), TypecheckedStmt(..), - TypecheckedMatch(..), TypecheckedHsModule(..), - TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..), - TypecheckedRecordBinds(..), + TypecheckedHsBinds, + TypecheckedMonoBinds, TypecheckedPat, + TypecheckedHsExpr, TypecheckedArithSeqInfo, + TypecheckedStmt, TypecheckedForeignDecl, + TypecheckedMatch, TypecheckedHsModule, + TypecheckedGRHSs, TypecheckedGRHS, + TypecheckedRecordBinds, TypecheckedDictBinds, mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, - tcIdType, - zonkBinds, - zonkInst, - zonkId, -- TcIdBndr s -> NF_TcM s Id - unZonkId -- Id -> NF_TcM s (TcIdBndr s) + -- re-exported from TcEnv + TcId, tcInstId, + + maybeBoxedPrimType, + + zonkTopBinds, zonkId, zonkIdOcc, + zonkForeignExports ) where -import Ubiq{-uitous-} +#include "HsVersions.h" -- friends: import HsSyn -- oodles of it -import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids - DictVar(..), idType - ) -- others: -import TcMonad -import TcType ( TcType(..), TcMaybe, TcTyVar(..), - zonkTcTypeToType, zonkTcTyVarToTyVar, - tcInstType +import Id ( idName, idType, setIdType, omitIfaceSigForId, Id ) +import DataCon ( DataCon, dataConArgTys ) +import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv, + ValueEnv, TcId, tcInstId ) -import Usage ( UVar(..) ) -import Util ( panic ) -import PprType ( GenType, GenTyVar ) -- instances -import TyVar ( GenTyVar ) -- instances -import Unique ( Unique ) -- instances +import TcMonad +import TcType ( TcType, TcTyVar, + zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType + ) +import TyCon ( isDataTyCon ) +import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type ) +import Name ( isLocallyDefined ) +import Var ( TyVar ) +import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList ) +import VarSet ( isEmptyVarSet ) +import CoreSyn ( Expr ) +import Bag +import UniqFM +import Outputable \end{code} @@ -67,37 +74,35 @@ At the end of type checking we zonk everything to @Typechecked...@ datatypes, which have immutable type variables in them. \begin{code} -type TcIdBndr s = GenId (TcType s) -- Binders are all TcTypes -data TcIdOcc s = TcId (TcIdBndr s) -- Bindees may be either - | RealId Id - -type TcHsBinds s = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcBind s = Bind (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat 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 TcQual s = Qual (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 TypecheckedPat = OutPat TyVar UVar Id -type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat -type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat -type TypecheckedBind = Bind TyVar UVar Id TypecheckedPat -type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat -type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat -type TypecheckedQual = Qual 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 TcHsBinds = HsBinds TcId TcPat +type TcMonoBinds = MonoBinds TcId TcPat +type TcDictBinds = TcMonoBinds +type TcPat = OutPat TcId +type TcExpr = HsExpr TcId TcPat +type TcGRHSs = GRHSs TcId TcPat +type TcGRHS = GRHS TcId TcPat +type TcMatch = Match TcId TcPat +type TcStmt = Stmt TcId TcPat +type TcArithSeqInfo = ArithSeqInfo TcId TcPat +type TcRecordBinds = HsRecordBinds TcId TcPat +type TcHsModule = HsModule TcId TcPat + +type TcCoreExpr = Expr TcId +type TcForeignExportDecl = ForeignDecl TcId + +type TypecheckedPat = OutPat Id +type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat +type TypecheckedDictBinds = TypecheckedMonoBinds +type TypecheckedHsBinds = HsBinds Id TypecheckedPat +type TypecheckedHsExpr = HsExpr Id TypecheckedPat +type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat +type TypecheckedStmt = Stmt Id TypecheckedPat +type TypecheckedMatch = Match Id TypecheckedPat +type TypecheckedGRHSs = GRHSs Id TypecheckedPat +type TypecheckedGRHS = GRHS Id TypecheckedPat +type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat +type TypecheckedHsModule = HsModule Id TypecheckedPat +type TypecheckedForeignDecl = ForeignDecl Id \end{code} \begin{code} @@ -112,171 +117,216 @@ mkHsTyLam tyvars expr = TyLam tyvars expr mkHsDictLam [] expr = expr mkHsDictLam dicts expr = DictLam dicts expr - -tcIdType :: TcIdOcc s -> TcType s -tcIdType (TcId id) = idType id -tcIdType other = panic "tcIdType" \end{code} +%************************************************************************ +%* * +\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. \begin{code} -instance Eq (TcIdOcc s) where - (TcId id1) == (TcId id2) = id1 == id2 - (RealId id1) == (RealId id2) = id1 == id2 - -instance Outputable (TcIdOcc s) where - ppr sty (TcId id) = ppr sty id - ppr sty (RealId id) = ppr sty id - -instance NamedThing (TcIdOcc s) where - getName (TcId id) = getName id - getName (RealId id) = getName id +maybeBoxedPrimType :: Type -> Maybe (DataCon, 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, + | isUnLiftedType data_con_arg_ty -- which is primitive + -> Just (data_con, data_con_arg_ty) + other_cases -> Nothing + other_cases -> Nothing \end{code} - %************************************************************************ %* * \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} %* * %************************************************************************ -\begin{code} -zonkId :: TcIdOcc s -> NF_TcM s Id -unZonkId :: Id -> NF_TcM s (TcIdBndr s) +This zonking pass runs over the bindings -zonkId (RealId id) = returnNF_Tc id + a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc + b) convert unbound TcTyVar to Void + c) convert each TcId to an Id by zonking its type -zonkId (TcId (Id u ty details prags info)) - = zonkTcTypeToType ty `thenNF_Tc` \ ty' -> - returnNF_Tc (Id u ty' details prags info) +The type variables are converted by binding mutable tyvars to immutable ones +and then zonking as normal. -unZonkId (Id u ty details prags info) - = tcInstType [] ty `thenNF_Tc` \ ty' -> - returnNF_Tc (Id u ty' details prags info) -\end{code} +The Ids are converted by binding them in the normal Tc envt; that +way we maintain sharing; eg an Id is zonked at its binding site and they +all occurrences of that Id point to the common zonked copy -\begin{code} -zonkInst :: (TcIdOcc s, TcExpr s) -> NF_TcM s (Id, TypecheckedHsExpr) -zonkInst (id, expr) - = zonkId id `thenNF_Tc` \ id' -> - zonkExpr expr `thenNF_Tc` \ expr' -> - returnNF_Tc (id', expr') -\end{code} +It's all pretty boring stuff, because HsSyn is such a large type, and +the environment manipulation is tiresome. \begin{code} -zonkBinds :: TcHsBinds s -> NF_TcM s TypecheckedHsBinds - -zonkBinds EmptyBinds = returnNF_Tc EmptyBinds - -zonkBinds (ThenBinds binds1 binds2) - = zonkBinds binds1 `thenNF_Tc` \ new_binds1 -> - zonkBinds binds2 `thenNF_Tc` \ new_binds2 -> - returnNF_Tc (ThenBinds new_binds1 new_binds2) +-- zonkId is used *during* typechecking just to zonk the Id's type +zonkId :: TcId -> NF_TcM s TcId +zonkId id + = zonkTcType (idType id) `thenNF_Tc` \ ty' -> + returnNF_Tc (setIdType id ty') + +-- zonkIdBndr is used *after* typechecking to get the Id's type +-- to its final form. The TyVarEnv give +zonkIdBndr :: TcId -> NF_TcM s Id +zonkIdBndr id + = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' -> + returnNF_Tc (setIdType id ty') + +zonkIdOcc :: TcId -> NF_TcM s Id +zonkIdOcc id + | not (isLocallyDefined id) || omitIfaceSigForId id + -- The omitIfaceSigForId thing may look wierd but it's quite + -- sensible really. We're avoiding looking up superclass selectors + -- and constructors; zonking them is a no-op anyway, and the + -- superclass selectors aren't in the environment anyway. + = returnNF_Tc id + | otherwise + = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' -> + let + new_id = case maybe_id' of + Just id' -> id' + Nothing -> pprTrace "zonkIdOcc: " (ppr id) id + in + returnNF_Tc new_id +\end{code} -zonkBinds (SingleBind bind) - = zonkBind bind `thenNF_Tc` \ new_bind -> - returnNF_Tc (SingleBind new_bind) -zonkBinds (AbsBinds tyvars dicts locprs dict_binds val_bind) - = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc subst_pair locprs `thenNF_Tc` \ new_locprs -> - mapNF_Tc subst_bind dict_binds `thenNF_Tc` \ new_dict_binds -> - zonkBind val_bind `thenNF_Tc` \ new_val_bind -> - returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind) +\begin{code} +zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv) +zonkTopBinds binds -- Top level is implicitly recursive + = fixNF_Tc (\ ~(_, new_ids) -> + tcExtendGlobalValEnv (bagToList new_ids) $ + zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) -> + tcGetValueEnv `thenNF_Tc` \ env -> + returnNF_Tc ((binds', env), new_ids) + ) `thenNF_Tc` \ (stuff, _) -> + returnNF_Tc stuff + +zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv) + +zonkBinds binds + = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (binds', env)) where - subst_pair (l, g) - = zonkId l `thenNF_Tc` \ new_l -> - zonkId g `thenNF_Tc` \ new_g -> - returnNF_Tc (new_l, new_g) - - subst_bind (v, e) - = zonkId v `thenNF_Tc` \ new_v -> - zonkExpr e `thenNF_Tc` \ new_e -> - returnNF_Tc (new_v, new_e) + -- go :: TcHsBinds + -- -> (TypecheckedHsBinds + -- -> NF_TcM s (TypecheckedHsBinds, TcEnv) + -- ) + -- -> NF_TcM s (TypecheckedHsBinds, TcEnv) + + go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' -> + go b2 $ \ b2' -> + thing_inside (b1' `ThenBinds` b2') + + go EmptyBinds thing_inside = thing_inside EmptyBinds + + go (MonoBind bind sigs is_rec) thing_inside + = ASSERT( null sigs ) + fixNF_Tc (\ ~(_, new_ids) -> + tcExtendGlobalValEnv (bagToList new_ids) $ + zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) -> + thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff -> + returnNF_Tc (stuff, new_ids) + ) `thenNF_Tc` \ (stuff, _) -> + returnNF_Tc stuff \end{code} \begin{code} ------------------------------------------------------------------------- -zonkBind :: TcBind s -> NF_TcM s TypecheckedBind - -zonkBind EmptyBind = returnNF_Tc EmptyBind - -zonkBind (NonRecBind mbinds) - = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> - returnNF_Tc (NonRecBind new_mbinds) +zonkMonoBinds :: TcMonoBinds + -> NF_TcM s (TypecheckedMonoBinds, Bag Id) -zonkBind (RecBind mbinds) - = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> - returnNF_Tc (RecBind new_mbinds) - -------------------------------------------------------------------------- -zonkMonoBinds :: TcMonoBinds s -> NF_TcM s TypecheckedMonoBinds - -zonkMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds +zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag) zonkMonoBinds (AndMonoBinds mbinds1 mbinds2) - = zonkMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 -> - zonkMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 -> - returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2) + = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) -> + zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) -> + returnNF_Tc (b1' `AndMonoBinds` b2', + ids1 `unionBags` ids2) -zonkMonoBinds (PatMonoBind pat grhss_w_binds locn) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> - returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn) +zonkMonoBinds (PatMonoBind pat grhss locn) + = zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> + zonkGRHSs grhss `thenNF_Tc` \ new_grhss -> + returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids) zonkMonoBinds (VarMonoBind var expr) - = zonkId var `thenNF_Tc` \ new_var -> + = zonkIdBndr var `thenNF_Tc` \ new_var -> zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (VarMonoBind new_var new_expr) + returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var) + +zonkMonoBinds (CoreMonoBind var core_expr) + = zonkIdBndr var `thenNF_Tc` \ new_var -> + returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var) -zonkMonoBinds (FunMonoBind name inf ms locn) - = zonkId name `thenNF_Tc` \ new_name -> - mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (FunMonoBind new_name inf new_ms locn) +zonkMonoBinds (FunMonoBind var inf ms locn) + = zonkIdBndr var `thenNF_Tc` \ new_var -> + mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> + returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var) + + +zonkMonoBinds (AbsBinds tyvars dicts exports val_bind) + = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> + -- No need to extend tyvar env: the effects are + -- propagated through binding the tyvars themselves + + mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts -> + tcExtendGlobalValEnv new_dicts $ + + fixNF_Tc (\ ~(_, _, val_bind_ids) -> + tcExtendGlobalValEnv (bagToList val_bind_ids) $ + zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) -> + mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports -> + returnNF_Tc (new_val_bind, new_exports, val_bind_ids) + ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) -> + let + new_globals = listToBag [global | (_, global, local) <- new_exports] + in + returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind, + new_globals) + where + zonkExport (tyvars, global, local) + = mapNF_Tc zonkTcTyVarBndr tyvars `thenNF_Tc` \ new_tyvars -> + zonkIdBndr global `thenNF_Tc` \ new_global -> + zonkIdOcc local `thenNF_Tc` \ new_local -> + returnNF_Tc (new_tyvars, new_global, new_local) \end{code} %************************************************************************ %* * -\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds} +\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} %* * %************************************************************************ \begin{code} -zonkMatch :: TcMatch s -> NF_TcM s TypecheckedMatch +zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch -zonkMatch (PatMatch pat match) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkMatch match `thenNF_Tc` \ new_match -> - returnNF_Tc (PatMatch new_pat new_match) - -zonkMatch (GRHSMatch grhss_w_binds) - = zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> - returnNF_Tc (GRHSMatch new_grhss_w_binds) - -zonkMatch (SimpleMatch expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (SimpleMatch new_expr) +zonkMatch (Match _ pats _ grhss) + = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) -> + tcExtendGlobalValEnv (bagToList new_ids) $ + zonkGRHSs grhss `thenNF_Tc` \ new_grhss -> + returnNF_Tc (Match [] new_pats Nothing new_grhss) ------------------------------------------------------------------------- -zonkGRHSsAndBinds :: TcGRHSsAndBinds s - -> NF_TcM s TypecheckedGRHSsAndBinds - -zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) - = mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> - zonkBinds binds `thenNF_Tc` \ new_binds -> +zonkGRHSs :: TcGRHSs + -> NF_TcM s TypecheckedGRHSs + +zonkGRHSs (GRHSs grhss binds (Just ty)) + = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> + tcSetEnv new_env $ + let + zonk_grhs (GRHS guarded locn) + = zonkStmts guarded `thenNF_Tc` \ new_guarded -> + returnNF_Tc (GRHS new_guarded locn) + in + mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty) - where - zonk_grhs (GRHS guard expr locn) - = zonkExpr guard `thenNF_Tc` \ new_guard -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (GRHS new_guard new_expr locn) - - zonk_grhs (OtherwiseGRHS expr locn) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (OtherwiseGRHS new_expr locn) + returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty)) \end{code} %************************************************************************ @@ -286,11 +336,11 @@ zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) %************************************************************************ \begin{code} -zonkExpr :: TcExpr s -> NF_TcM s TypecheckedHsExpr +zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr -zonkExpr (HsVar name) - = zonkId name `thenNF_Tc` \ new_name -> - returnNF_Tc (HsVar new_name) +zonkExpr (HsVar id) + = zonkIdOcc id `thenNF_Tc` \ id' -> + returnNF_Tc (HsVar id') zonkExpr (HsLit _) = panic "zonkExpr:HsLit" @@ -307,14 +357,14 @@ zonkExpr (HsApp e1 e2) zonkExpr e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (HsApp new_e1 new_e2) -zonkExpr (OpApp e1 op e2) +zonkExpr (OpApp e1 op fixity e2) = zonkExpr e1 `thenNF_Tc` \ new_e1 -> zonkExpr op `thenNF_Tc` \ new_op -> zonkExpr e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (OpApp new_e1 new_op new_e2) + returnNF_Tc (OpApp new_e1 new_op fixity new_e2) -zonkExpr (NegApp _ _) = panic "zonkExpr:NegApp" -zonkExpr (HsPar _) = panic "zonkExpr:HsPar" +zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp" +zonkExpr (HsPar _) = panic "zonkExpr: HsPar" zonkExpr (SectionL expr op) = zonkExpr expr `thenNF_Tc` \ new_expr -> @@ -323,7 +373,7 @@ zonkExpr (SectionL expr op) zonkExpr (SectionR op expr) = zonkExpr op `thenNF_Tc` \ new_op -> - zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (SectionR new_op new_expr) zonkExpr (HsCase expr ms src_loc) @@ -338,49 +388,54 @@ zonkExpr (HsIf e1 e2 e3 src_loc) returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc) zonkExpr (HsLet binds expr) - = zonkBinds binds `thenNF_Tc` \ new_binds -> + = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> + tcSetEnv new_env $ zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsLet new_binds new_expr) -zonkExpr (HsDo _ _) = panic "zonkExpr:HsDo" +zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo" -zonkExpr (HsDoOut stmts m_id mz_id src_loc) - = zonkStmts stmts `thenNF_Tc` \ new_stmts -> - zonkId m_id `thenNF_Tc` \ m_new -> - zonkId mz_id `thenNF_Tc` \ mz_new -> - returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc) - -zonkExpr (ListComp expr quals) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkQuals quals `thenNF_Tc` \ new_quals -> - returnNF_Tc (ListComp new_expr new_quals) +zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) + = zonkStmts stmts `thenNF_Tc` \ new_stmts -> + zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkIdOcc return_id `thenNF_Tc` \ new_return_id -> + zonkIdOcc then_id `thenNF_Tc` \ new_then_id -> + zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id -> + returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id + new_ty src_loc) zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList" zonkExpr (ExplicitListOut ty exprs) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitListOut new_ty new_exprs) -zonkExpr (ExplicitTuple exprs) - = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (ExplicitTuple new_exprs) +zonkExpr (ExplicitTuple exprs boxed) + = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitTuple new_exprs boxed) -zonkExpr (RecordCon con rbinds) - = zonkExpr con `thenNF_Tc` \ new_con -> +zonkExpr (HsCon data_con tys exprs) + = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> + mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (HsCon data_con new_tys new_exprs) + +zonkExpr (RecordConOut data_con con_expr rbinds) + = zonkExpr con_expr `thenNF_Tc` \ new_con_expr -> zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordCon new_con new_rbinds) + returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds) zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd" -zonkExpr (RecordUpdOut expr ids rbinds) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkId ids `thenNF_Tc` \ new_ids -> +zonkExpr (RecordUpdOut expr ty dicts rbinds) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordUpdOut new_expr new_ids new_rbinds) + returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds) zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" -zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" +zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" zonkExpr (ArithSeqOut expr info) = zonkExpr expr `thenNF_Tc` \ new_expr -> @@ -398,46 +453,31 @@ zonkExpr (HsSCC label expr) zonkExpr (TyLam tyvars expr) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> + -- No need to extend tyvar env; see AbsBinds + zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (TyLam new_tyvars new_expr) zonkExpr (TyApp expr tys) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> + = zonkExpr expr `thenNF_Tc` \ new_expr -> + mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> returnNF_Tc (TyApp new_expr new_tys) zonkExpr (DictLam dicts expr) - = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - zonkExpr expr `thenNF_Tc` \ new_expr -> + = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts -> + tcExtendGlobalValEnv new_dicts $ + zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (DictLam new_dicts new_expr) zonkExpr (DictApp expr dicts) = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> + mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> returnNF_Tc (DictApp new_expr new_dicts) -zonkExpr (ClassDictLam dicts methods expr) - = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (ClassDictLam new_dicts new_methods new_expr) - -zonkExpr (Dictionary dicts methods) - = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods -> - returnNF_Tc (Dictionary new_dicts new_methods) - -zonkExpr (SingleDict name) - = zonkId name `thenNF_Tc` \ new_name -> - returnNF_Tc (SingleDict new_name) -zonkExpr (HsCon con tys vargs) - = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> - mapNF_Tc zonkExpr vargs `thenNF_Tc` \ new_vargs -> - returnNF_Tc (HsCon con new_tys new_vargs) ------------------------------------------------------------------------- -zonkArithSeq :: TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo +zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo zonkArithSeq (From e) = zonkExpr e `thenNF_Tc` \ new_e -> @@ -460,52 +500,49 @@ zonkArithSeq (FromThenTo e1 e2 e3) returnNF_Tc (FromThenTo new_e1 new_e2 new_e3) ------------------------------------------------------------------------- -zonkQuals :: [TcQual s] -> NF_TcM s [TypecheckedQual] +zonkStmts :: [TcStmt] + -> NF_TcM s [TypecheckedStmt] -zonkQuals quals - = mapNF_Tc zonk_qual quals - where - zonk_qual (GeneratorQual pat expr) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (GeneratorQual new_pat new_expr) +zonkStmts [] = returnNF_Tc [] - zonk_qual (FilterQual expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (FilterQual new_expr) +zonkStmts [ReturnStmt expr] + = zonkExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc [ReturnStmt new_expr] - zonk_qual (LetQual binds) - = zonkBinds binds `thenNF_Tc` \ new_binds -> - returnNF_Tc (LetQual new_binds) +zonkStmts (ExprStmt expr locn : stmts) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkStmts stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ExprStmt new_expr locn : new_stmts) -------------------------------------------------------------------------- -zonkStmts :: [TcStmt s] -> NF_TcM s [TypecheckedStmt] +zonkStmts (GuardStmt expr locn : stmts) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkStmts stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (GuardStmt new_expr locn : new_stmts) -zonkStmts stmts - = mapNF_Tc zonk_stmt stmts - where - zonk_stmt (BindStmt pat expr src_loc) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (BindStmt new_pat new_expr src_loc) +zonkStmts (LetStmt binds : stmts) + = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> + tcSetEnv new_env $ + zonkStmts stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (LetStmt new_binds : new_stmts) + +zonkStmts (BindStmt pat expr locn : stmts) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) -> + tcExtendGlobalValEnv (bagToList new_ids) $ + zonkStmts stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts) - zonk_stmt (ExprStmt expr src_loc) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (ExprStmt new_expr src_loc) - zonk_stmt (LetStmt binds) - = zonkBinds binds `thenNF_Tc` \ new_binds -> - returnNF_Tc (LetStmt new_binds) ------------------------------------------------------------------------- -zonkRbinds :: TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds +zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds zonkRbinds rbinds = mapNF_Tc zonk_rbind rbinds where zonk_rbind (field, expr, pun) - = zonkId field `thenNF_Tc` \ new_field -> - zonkExpr expr `thenNF_Tc` \ new_expr -> + = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkIdOcc field `thenNF_Tc` \ new_field -> returnNF_Tc (new_field, new_expr, pun) \end{code} @@ -516,67 +553,101 @@ zonkRbinds rbinds %************************************************************************ \begin{code} -zonkPat :: TcPat s -> NF_TcM s TypecheckedPat +zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id) zonkPat (WildPat ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (WildPat new_ty) + returnNF_Tc (WildPat new_ty, emptyBag) zonkPat (VarPat v) - = zonkId v `thenNF_Tc` \ new_v -> - returnNF_Tc (VarPat new_v) + = zonkIdBndr v `thenNF_Tc` \ new_v -> + returnNF_Tc (VarPat new_v, unitBag new_v) zonkPat (LazyPat pat) - = zonkPat pat `thenNF_Tc` \ new_pat -> - returnNF_Tc (LazyPat new_pat) + = zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> + returnNF_Tc (LazyPat new_pat, ids) zonkPat (AsPat n pat) - = zonkId n `thenNF_Tc` \ new_n -> - zonkPat pat `thenNF_Tc` \ new_pat -> - returnNF_Tc (AsPat new_n new_pat) - -zonkPat (ConPat n ty pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> - returnNF_Tc (ConPat n new_ty new_pats) - -zonkPat (ConOpPat pat1 op pat2 ty) - = zonkPat pat1 `thenNF_Tc` \ new_pat1 -> - zonkPat pat2 `thenNF_Tc` \ new_pat2 -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty) + = zonkIdBndr n `thenNF_Tc` \ new_n -> + zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> + returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids) zonkPat (ListPat ty pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> - returnNF_Tc (ListPat new_ty new_pats) - -zonkPat (TuplePat pats) - = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> - returnNF_Tc (TuplePat new_pats) - -zonkPat (RecPat n ty rpats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonk_rpat rpats `thenNF_Tc` \ new_rpats -> - returnNF_Tc (RecPat n new_ty new_rpats) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> + returnNF_Tc (ListPat new_ty new_pats, ids) + +zonkPat (TuplePat pats boxed) + = zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> + returnNF_Tc (TuplePat new_pats boxed, ids) + +zonkPat (ConPat n ty tvs dicts pats) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs -> + mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts -> + tcExtendGlobalValEnv new_dicts $ + zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> + returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats, + listToBag new_dicts `unionBags` ids) + +zonkPat (RecPat n ty tvs dicts rpats) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs -> + mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts -> + tcExtendGlobalValEnv new_dicts $ + mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) -> + returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats, + listToBag new_dicts `unionBags` unionManyBags ids_s) where zonk_rpat (f, pat, pun) - = zonkPat pat `thenNF_Tc` \ new_pat -> - returnNF_Tc (f, new_pat, pun) + = zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> + returnNF_Tc ((f, new_pat, pun), ids) zonkPat (LitPat lit ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (LitPat lit new_ty) + returnNF_Tc (LitPat lit new_ty, emptyBag) zonkPat (NPat lit ty expr) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (NPat lit new_ty new_expr) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (NPat lit new_ty new_expr, emptyBag) + +zonkPat (NPlusKPat n k ty e1 e2) + = zonkIdBndr n `thenNF_Tc` \ new_n -> + zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkExpr e1 `thenNF_Tc` \ new_e1 -> + zonkExpr e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n) zonkPat (DictPat ds ms) - = mapNF_Tc zonkId ds `thenNF_Tc` \ new_ds -> - mapNF_Tc zonkId ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (DictPat new_ds new_ms) + = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds -> + mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms -> + returnNF_Tc (DictPat new_ds new_ms, + listToBag new_ds `unionBags` listToBag new_ms) + + +zonkPats [] + = returnNF_Tc ([], emptyBag) + +zonkPats (pat:pats) + = zonkPat pat `thenNF_Tc` \ (pat', ids1) -> + zonkPats pats `thenNF_Tc` \ (pats', ids2) -> + returnNF_Tc (pat':pats', ids1 `unionBags` ids2) \end{code} +%************************************************************************ +%* * +\subsection[BackSubst-Foreign]{Foreign exports} +%* * +%************************************************************************ + +\begin{code} +zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl] +zonkForeignExports ls = mapNF_Tc zonkForeignExport ls + +zonkForeignExport :: TcForeignExportDecl -> 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}