X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=5223fe0348ab473ef9e0ff48112f36c70ad09b8b;hb=de905f504a3e129e2c4a1906d7e0a26e36cd6c4b;hp=1ff6f8fbceebcd46c434d48aeb4f2d4258bd3176;hpb=e9f23b4cc3df781f2fc84b48716a7779ecc8ab06;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 1ff6f8f..5223fe0 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -123,12 +123,12 @@ instance Outputable LetRhsFlag where instance Outputable SimplCont where ppr (Stop ty is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty - ppr (ApplyTo dup arg se cont) = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg) $$ - nest 2 (pprSimplEnv se)) $$ ppr cont + ppr (ApplyTo dup arg se cont) = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg) + {- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont ppr (StrictBind b _ _ _ cont) = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont ppr (StrictArg f _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$ - (nest 4 (ppr alts $$ pprSimplEnv se)) $$ ppr cont + (nest 4 (ppr alts)) $$ ppr cont ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont data DupFlag = OkToDup | NoDup @@ -1192,20 +1192,19 @@ prepareAlts scrut case_bndr' alts ; let (alts_wo_default, maybe_deflt) = findDefault alts alt_cons = [con | (con,_,_) <- alts_wo_default] imposs_deflt_cons = nub (imposs_cons ++ alt_cons) - -- "imposs_deflt_cons" are handled either by the context, - -- OR by a branch in this case expression. - -- Don't include DEFAULT!! + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. ; default_alts <- prepareDefault dflags scrut case_bndr' mb_tc_app imposs_deflt_cons maybe_deflt ; let trimmed_alts = filter possible_alt alts_wo_default - merged_alts = mergeAlts default_alts trimmed_alts + merged_alts = mergeAlts trimmed_alts default_alts -- We need the mergeAlts in case the new default_alt -- has turned into a constructor alternative. -- The merge keeps the inner DEFAULT at the front, if there is one - -- and eliminates any inner_alts that are shadowed by the outer_alts - + -- and interleaves the alternatives in the right order ; return (imposs_deflt_cons, merged_alts) } where @@ -1262,7 +1261,17 @@ prepareDefault dflags scrut outer_bndr bndr_ty imposs_cons (Just deflt_rhs) = do { tick (CaseMerge outer_bndr) ; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs - ; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts] } + ; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts, + not (con `elem` imposs_cons) ] + -- NB: filter out any imposs_cons. Example: + -- case x of + -- A -> e1 + -- DEFAULT -> case x of + -- A -> e2 + -- B -> e3 + -- When we merge, we must ensure that e1 takes + -- precedence over e2 as the value for A! + } -- Warning: don't call prepareAlts recursively! -- Firstly, there's no point, because inner alts have already had -- mkCase applied to them, so they won't have a case in their default