From 73cc7f0633daea7888534d52f12653ec9f128123 Mon Sep 17 00:00:00 2001 From: quintela Date: Tue, 2 Dec 1997 18:55:21 +0000 Subject: [PATCH] [project @ 1997-12-02 18:55:21 by quintela] Changes related with new types of MatchResult, EquationInfo and matchSimplify --- ghc/compiler/deSugar/DsUtils.lhs | 65 +++++++++++++++++++------------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 90fb708..ec7d252 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -10,6 +10,7 @@ This module exports some utility functions of no great interest. module DsUtils ( CanItFail(..), EquationInfo(..), MatchResult(..), + SYN_IE(EqnNo), SYN_IE(EqnSet), combineGRHSMatchResults, combineMatchResults, @@ -64,6 +65,7 @@ import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) import Unique ( Unique ) +import UniqSet import Usage ( SYN_IE(UVar) ) import SrcLoc ( SrcLoc {- instance Outputable -} ) @@ -107,8 +109,17 @@ The ``equation info'' used by @match@ is relatively complicated and worthy of a type synonym and a few handy functions. \begin{code} + +type EqnNo = Int +type EqnSet = UniqSet EqnNo + data EquationInfo = EqnInfo + EqnNo -- The number of the equation + DsMatchContext -- The context info is used when producing warnings + -- about shadowed patterns. It's the context + -- of the *first* thing matched in this group. + -- Should perhaps be a list of them all! [TypecheckedPat] -- the patterns for an eqn MatchResult -- Encapsulates the guards and bindings \end{code} @@ -124,11 +135,6 @@ data MatchResult -- failure point(s). The expression should -- be duplicatable! - DsMatchContext -- The context info is used when producing warnings - -- about shadowed patterns. It's the context - -- of the *first* thing matched in this group. - -- Should perhaps be a list of them all! - data CanItFail = CanFail | CantFail orFail CantFail CantFail = CantFail @@ -136,15 +142,14 @@ orFail _ _ = CanFail mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult -mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt) - = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt +mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn) + = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult -mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt) +mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn) = returnDs (MatchResult CanFail ty (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail) - cxt ) mkCoPrimCaseMatchResult :: Id -- Scrutinee @@ -154,16 +159,15 @@ mkCoPrimCaseMatchResult var alts = newSysLocalDs (idType var) `thenDs` \ wild -> returnDs (MatchResult CanFail ty1 - (mk_case alts wild) - cxt1) + (mk_case alts wild)) where - ((_,MatchResult _ ty1 _ cxt1) : _) = alts + ((_,MatchResult _ ty1 _) : _) = alts mk_case alts wild fail_expr = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr)) where final_alts = [ (lit, body_fn fail_expr) - | (lit, MatchResult _ _ body_fn _) <- alts + | (lit, MatchResult _ _ body_fn) <- alts ] @@ -183,8 +187,7 @@ mkCoAlgCaseMatchResult var alts [] -> -- All constructors mentioned, so no default needed returnDs (MatchResult can_any_alt_fail ty1 - (mk_case alts (\ignore -> NoDefault)) - cxt1) + (mk_case alts (\ignore -> NoDefault))) [con] -> -- Just one constructor missing, so add a case for it -- We need to build new locals for the args of the constructor, @@ -196,19 +199,17 @@ mkCoAlgCaseMatchResult var alts -- Now we are ready to construct the new alternative let - new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext) + new_alt = (con, arg_ids, MatchResult CanFail ty1 id) in returnDs (MatchResult CanFail ty1 - (mk_case (new_alt:alts) (\ignore -> NoDefault)) - cxt1) + (mk_case (new_alt:alts) (\ignore -> NoDefault))) other -> -- Many constructors missing, so use a default case newSysLocalDs scrut_ty `thenDs` \ wild -> returnDs (MatchResult CanFail ty1 - (mk_case alts (\fail_expr -> BindDefault wild fail_expr)) - cxt1) + (mk_case alts (\fail_expr -> BindDefault wild fail_expr))) where -- Common stuff scrut_ty = idType var @@ -230,28 +231,28 @@ mkCoAlgCaseMatchResult var alts = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] ) match_results = [match_result | (_,_,match_result) <- alts] - (MatchResult _ ty1 _ cxt1 : _) = match_results - can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results] + (MatchResult _ ty1 _ : _) = match_results + can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ <- match_results] mk_case alts deflt_fn fail_expr = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr)) where final_alts = [ (con, args, body_fn fail_expr) - | (con, args, MatchResult _ _ body_fn _) <- alts + | (con, args, MatchResult _ _ body_fn) <- alts ] combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult -combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1) - (MatchResult can_it_fail2 ty2 body_fn2 cxt2) +combineMatchResults (MatchResult CanFail ty1 body_fn1) + (MatchResult can_it_fail2 ty2 body_fn2) = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) -> let new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr) new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2) in - returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1) + returnDs (MatchResult can_it_fail2 ty1 new_body_fn2) -combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1) +combineMatchResults match_result1@(MatchResult CantFail ty body_fn1) match_result2 = returnDs match_result1 @@ -259,9 +260,9 @@ combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1) -- The difference in combineGRHSMatchResults is that there is no -- need to let-bind to avoid code duplication combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult -combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1) - (MatchResult can_it_fail ty2 body_fn2 cxt2) - = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1) +combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1) + (MatchResult can_it_fail ty2 body_fn2) + = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body))) combineGRHSMatchResults match_result1 match_result2 = -- Delegate to avoid duplication of code @@ -394,8 +395,8 @@ mkSelectorBinds pat val_expr = mkTupleBind binders val_expr | otherwise - = mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg -> - matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr -> + = mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_expr -> + matchSimply val_expr LetMatch pat res_ty local_tuple error_expr `thenDs` \ tuple_expr -> mkTupleBind binders tuple_expr where -- 1.7.10.4