X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FBackSubst.lhs;fp=ghc%2Fcompiler%2Ftypecheck%2FBackSubst.lhs;h=b42877b5ebd3e026792ac5f7bb281a4cd8a15847;hb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;hp=0000000000000000000000000000000000000000;hpb=e48474bff05e6cfb506660420f025f694c870d38;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/BackSubst.lhs b/ghc/compiler/typecheck/BackSubst.lhs new file mode 100644 index 0000000..b42877b --- /dev/null +++ b/ghc/compiler/typecheck/BackSubst.lhs @@ -0,0 +1,451 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[BackSubst]{Back substitution functions} + +This module applies a typechecker substitution over the whole abstract +syntax. + +\begin{code} +#include "HsVersions.h" + +module BackSubst ( + applyTcSubstToBinds, + + -- and to make the interface self-sufficient... + Subst, Binds, MonoBinds, Id, TypecheckedPat + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty + +import AbsSyn +import AbsUniType ( getTyVar ) +import TcMonad +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Binds]{Running a substitution over @Binds@} +%* * +%************************************************************************ + +\begin{code} +applyTcSubstToBinds :: TypecheckedBinds -> NF_TcM TypecheckedBinds + +applyTcSubstToBinds EmptyBinds = returnNF_Tc EmptyBinds + +applyTcSubstToBinds (ThenBinds binds1 binds2) + = applyTcSubstToBinds binds1 `thenNF_Tc` \ new_binds1 -> + applyTcSubstToBinds binds2 `thenNF_Tc` \ new_binds2 -> + returnNF_Tc (ThenBinds new_binds1 new_binds2) + +applyTcSubstToBinds (SingleBind bind) + = substBind bind `thenNF_Tc` \ new_bind -> + returnNF_Tc (SingleBind new_bind) + +applyTcSubstToBinds (AbsBinds tyvars dicts locprs dict_binds val_bind) + = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars -> + mapNF_Tc applyTcSubstToId 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 -> + substBind val_bind `thenNF_Tc` \ new_val_bind -> + returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind) + where + subst_pair (l, g) + = applyTcSubstToId l `thenNF_Tc` \ new_l -> + applyTcSubstToId g `thenNF_Tc` \ new_g -> + returnNF_Tc (new_l, new_g) + + subst_bind (v, e) + = applyTcSubstToInst v `thenNF_Tc` \ new_v -> + substExpr e `thenNF_Tc` \ new_e -> + returnNF_Tc (new_v, new_e) +\end{code} + +\begin{code} +------------------------------------------------------------------------- +substBind :: TypecheckedBind -> NF_TcM TypecheckedBind + +substBind (NonRecBind mbinds) + = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> + returnNF_Tc (NonRecBind new_mbinds) + +substBind (RecBind mbinds) + = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> + returnNF_Tc (RecBind new_mbinds) + +substBind other = returnNF_Tc other + +------------------------------------------------------------------------- +applyTcSubstToMonoBinds :: TypecheckedMonoBinds -> NF_TcM TypecheckedMonoBinds + +applyTcSubstToMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds + +applyTcSubstToMonoBinds (AndMonoBinds mbinds1 mbinds2) + = applyTcSubstToMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 -> + applyTcSubstToMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 -> + returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2) + +applyTcSubstToMonoBinds (PatMonoBind pat grhss_w_binds locn) + = substPat pat `thenNF_Tc` \ new_pat -> + substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> + returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn) + +applyTcSubstToMonoBinds (VarMonoBind var expr) + = applyTcSubstToId var `thenNF_Tc` \ new_var -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (VarMonoBind new_var new_expr) + +applyTcSubstToMonoBinds (FunMonoBind name ms locn) + = applyTcSubstToId name `thenNF_Tc` \ new_name -> + mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms -> + returnNF_Tc (FunMonoBind new_name new_ms locn) +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds} +%* * +%************************************************************************ + +\begin{code} +substMatch :: TypecheckedMatch -> NF_TcM TypecheckedMatch + +substMatch (PatMatch pat match) + = substPat pat `thenNF_Tc` \ new_pat -> + substMatch match `thenNF_Tc` \ new_match -> + returnNF_Tc (PatMatch new_pat new_match) + +substMatch (GRHSMatch grhss_w_binds) + = substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> + returnNF_Tc (GRHSMatch new_grhss_w_binds) + +------------------------------------------------------------------------- +substGRHSsAndBinds :: TypecheckedGRHSsAndBinds + -> NF_TcM TypecheckedGRHSsAndBinds + +substGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) + = mapNF_Tc subst_grhs grhss `thenNF_Tc` \ new_grhss -> + applyTcSubstToBinds binds `thenNF_Tc` \ new_binds -> + applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty) + where + subst_grhs (GRHS guard expr locn) + = substExpr guard `thenNF_Tc` \ new_guard -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (GRHS new_guard new_expr locn) + + subst_grhs (OtherwiseGRHS expr locn) + = substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (OtherwiseGRHS new_expr locn) +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Expr]{Running a substitution over a TypeCheckedExpr} +%* * +%************************************************************************ + +ToDo: panic on things that can't be in @TypecheckedExpr@. + +\begin{code} +substExpr :: TypecheckedExpr -> NF_TcM TypecheckedExpr + +substExpr (Var name) + = applyTcSubstToId name `thenNF_Tc` \ new_name -> + returnNF_Tc (Var new_name) + +substExpr (Lit (LitLitLit s ty)) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (Lit (LitLitLit s new_ty)) + +substExpr other_lit@(Lit lit) = returnNF_Tc other_lit + +substExpr (Lam match) + = substMatch match `thenNF_Tc` \ new_match -> + returnNF_Tc (Lam new_match) + +substExpr (App e1 e2) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (App new_e1 new_e2) + +substExpr (OpApp e1 op e2) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr op `thenNF_Tc` \ new_op -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (OpApp new_e1 new_op new_e2) + +substExpr (SectionL expr op) + = substExpr expr `thenNF_Tc` \ new_expr -> + substExpr op `thenNF_Tc` \ new_op -> + returnNF_Tc (SectionL new_expr new_op) + +substExpr (SectionR op expr) + = substExpr op `thenNF_Tc` \ new_op -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (SectionR new_op new_expr) + +substExpr (CCall fun args may_gc is_casm result_ty) + = mapNF_Tc substExpr args `thenNF_Tc` \ new_args -> + applyTcSubstToTy result_ty `thenNF_Tc` \ new_result_ty -> + returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty) + +substExpr (SCC label expr) + = substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (SCC label new_expr) + +substExpr (Case expr ms) + = substExpr expr `thenNF_Tc` \ new_expr -> + mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms -> + returnNF_Tc (Case new_expr new_ms) + +substExpr (ListComp expr quals) + = substExpr expr `thenNF_Tc` \ new_expr -> + substQuals quals `thenNF_Tc` \ new_quals -> + returnNF_Tc (ListComp new_expr new_quals) + +substExpr (Let binds expr) + = applyTcSubstToBinds binds `thenNF_Tc` \ new_binds -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (Let new_binds new_expr) + +--ExplicitList: not in typechecked exprs + +substExpr (ExplicitListOut ty exprs) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitListOut new_ty new_exprs) + +substExpr (ExplicitTuple exprs) + = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitTuple new_exprs) + +substExpr (If e1 e2 e3) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + substExpr e3 `thenNF_Tc` \ new_e3 -> + returnNF_Tc (If new_e1 new_e2 new_e3) + +substExpr (ArithSeqOut expr info) + = substExpr expr `thenNF_Tc` \ new_expr -> + substArithSeq info `thenNF_Tc` \ new_info -> + returnNF_Tc (ArithSeqOut new_expr new_info) + +substExpr (TyLam tyvars expr) + = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (TyLam new_tyvars new_expr) + +substExpr (TyApp expr tys) + = substExpr expr `thenNF_Tc` \ new_expr -> + mapNF_Tc (applyTcSubstToTy) tys `thenNF_Tc` \ new_tys -> + returnNF_Tc (TyApp new_expr new_tys) + +substExpr (DictLam dicts expr) + = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (DictLam new_dicts new_expr) + +substExpr (DictApp expr dicts) + = substExpr expr `thenNF_Tc` \ new_expr -> + mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts -> + returnNF_Tc (DictApp new_expr new_dicts) + +substExpr (ClassDictLam dicts methods expr) + = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts -> + mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (ClassDictLam new_dicts new_methods new_expr) + +substExpr (Dictionary dicts methods) + = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts -> + mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods -> + returnNF_Tc (Dictionary new_dicts new_methods) + +substExpr (SingleDict name) + = applyTcSubstToId name `thenNF_Tc` \ new_name -> + returnNF_Tc (SingleDict new_name) + +#ifdef DPH + +substExpr (ParallelZF expr quals) + = substExpr expr `thenNF_Tc` \ new_expr -> + substParQuals quals `thenNF_Tc` \ new_quals -> + returnNF_Tc (ParallelZF new_expr new_quals) + +--substExpr (ExplicitPodIn exprs) :: not in typechecked + +substExpr (ExplicitPodOut ty exprs) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitPodOut new_ty new_exprs) + +substExpr (ExplicitProcessor exprs expr) + = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (ExplicitProcessor new_exprs new_expr) + +#endif {- Data Parallel Haskell -} + +------------------------------------------------------------------------- +substArithSeq :: TypecheckedArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo + +substArithSeq (From e) + = substExpr e `thenNF_Tc` \ new_e -> + returnNF_Tc (From new_e) + +substArithSeq (FromThen e1 e2) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (FromThen new_e1 new_e2) + +substArithSeq (FromTo e1 e2) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (FromTo new_e1 new_e2) + +substArithSeq (FromThenTo e1 e2 e3) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + substExpr e3 `thenNF_Tc` \ new_e3 -> + returnNF_Tc (FromThenTo new_e1 new_e2 new_e3) + +------------------------------------------------------------------------- +substQuals :: [TypecheckedQual] -> NF_TcM [TypecheckedQual] + +substQuals quals + = mapNF_Tc subst_qual quals + where + subst_qual (GeneratorQual pat expr) + = substPat pat `thenNF_Tc` \ new_pat -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (GeneratorQual new_pat new_expr) + + subst_qual (FilterQual expr) + = substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (FilterQual new_expr) + +------------------------------------------------------------------------- +#ifdef DPH +substParQuals :: TypecheckedParQuals -> NF_TcM TypecheckedParQuals + +substParQuals (AndParQuals quals1 quals2) + = substParQuals quals1 `thenNF_Tc` \ new_quals1 -> + substParQuals quals2 `thenNF_Tc` \ new_quals2 -> + returnNF_Tc (AndParQuals new_quals1 new_quals2) + +--substParQuals (DrawnGenIn pats pat expr) :: not in typechecked + +substParQuals (DrawnGenOut pats convs pat expr) + = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs -> + substPat pat `thenNF_Tc` \ new_pat -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (DrawnGenOut new_pats new_convs new_pat new_expr) + +substParQuals (IndexGen pats pat expr) + = mapNF_Tc substExpr pats `thenNF_Tc` \ new_pats -> + substPat pat `thenNF_Tc` \ new_pat -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (IndexGen new_pats new_pat new_expr) + +substParQuals (ParFilter expr) + = substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (ParFilter new_expr) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Pats]{Patterns} +%* * +%************************************************************************ + +\begin{code} +substPat :: TypecheckedPat -> NF_TcM TypecheckedPat + +substPat (WildPat ty) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (WildPat new_ty) + +substPat (VarPat v) + = applyTcSubstToId v `thenNF_Tc` \ new_v -> + returnNF_Tc (VarPat new_v) + +substPat (LazyPat pat) + = substPat pat `thenNF_Tc` \ new_pat -> + returnNF_Tc (LazyPat new_pat) + +substPat (AsPat n pat) + = applyTcSubstToId n `thenNF_Tc` \ new_n -> + substPat pat `thenNF_Tc` \ new_pat -> + returnNF_Tc (AsPat new_n new_pat) + +substPat (ConPat n ty pats) + = applyTcSubstToId n `thenNF_Tc` \ new_n -> + -- ToDo: "n"'s global, so omit? + applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + returnNF_Tc (ConPat new_n new_ty new_pats) + +substPat (ConOpPat pat1 op pat2 ty) + = substPat pat1 `thenNF_Tc` \ new_pat1 -> + applyTcSubstToId op `thenNF_Tc` \ new_op -> + substPat pat2 `thenNF_Tc` \ new_pat2 -> + applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (ConOpPat new_pat1 new_op new_pat2 new_ty) + +substPat (ListPat ty pats) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + returnNF_Tc (ListPat new_ty new_pats) + +substPat (TuplePat pats) + = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + returnNF_Tc (TuplePat new_pats) + +substPat (LitPat lit ty) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (LitPat lit new_ty) + +substPat (NPat lit ty expr) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (NPat lit new_ty new_expr) + +substPat (NPlusKPat n k ty e1 e2 e3) + = applyTcSubstToId n `thenNF_Tc` \ new_n -> + applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + substExpr e3 `thenNF_Tc` \ new_e3 -> + returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2 new_e3) + +#ifdef DPH +substPat (ProcessorPat pats convs pat) + = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs -> + substPat pat `thenNF_Tc` \ new_pat -> + returnNF_Tc (ProcessorPat new_pats new_convs new_pat) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-TyVar]{Running a substitution over type variables} +%* * +%************************************************************************ + +The type variables in an @AbsBinds@ or @TyLam@ may have a binding in the +substitution as a result of a @matchTy@ call. So we should subsitute for +them too. The result should certainly be a type variable. + +\begin{code} +subst_tyvars tyvars + = mapNF_Tc applyTcSubstToTyVar tyvars `thenNF_Tc` \ new_tyvar_tys -> + returnNF_Tc (map (getTyVar "subst_tyvars") new_tyvar_tys) +\end{code}