From 58e45ee86bbda3f24a4caf41c0aea7a6b787367e Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 5 Nov 2007 16:13:14 +0000 Subject: [PATCH] Fix an old but subtle bug in the Simplifier I got a Core Lint failure when compiling System.Win32.Info in the Win32 package. It was very delicate: adding or removing a function definition elsewhere in the module (unrelated to the error) made the error go away. Happily, I found it. In SimplUtils.prepareDefault I was comparing an InId with an OutId. We were getting a spurious hit, and hence doing a bogus CaseMerge. This bug has been lurking ever since I re-factored the way that case expressions were simplified, about 6 months ago! --- compiler/simplCore/SimplEnv.lhs | 8 +++++--- compiler/simplCore/SimplUtils.lhs | 35 +++++++++++++++++------------------ compiler/simplCore/Simplify.lhs | 4 ++-- 3 files changed, 24 insertions(+), 23 deletions(-) diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 1b05737..d0240fb 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -456,14 +456,16 @@ floatBinds (Floats bs _) = fromOL bs \begin{code} substId :: SimplEnv -> Id -> SimplSR +-- Returns DoneEx only on a non-Var expression substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v | not (isLocalId v) = DoneId v | otherwise -- A local Id = case lookupVarEnv ids v of - Just (DoneId v) -> DoneId (refine in_scope v) - Just res -> res - Nothing -> DoneId (refine in_scope v) + Nothing -> DoneId (refine in_scope v) + Just (DoneId v) -> DoneId (refine in_scope v) + Just (DoneEx (Var v)) -> DoneId (refine in_scope v) + Just res -> res -- DoneEx non-var, or ContEx where -- Get the most up-to-date thing from the in-scope set diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index e8714d4..9bc7826 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -1231,8 +1231,8 @@ have to check that r doesn't mention the variables bound by the pattern in each alternative, so the binder-info is rather useful. \begin{code} -prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) -prepareAlts scrut case_bndr' alts +prepareAlts :: SimplEnv -> OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +prepareAlts env scrut case_bndr' alts = do { dflags <- getDOptsSmpl ; alts <- combineIdenticalAlts case_bndr' alts @@ -1243,7 +1243,7 @@ prepareAlts scrut case_bndr' alts -- EITHER by the context, -- OR by a non-DEFAULT branch in this case expression. - ; default_alts <- prepareDefault dflags scrut case_bndr' mb_tc_app + ; default_alts <- prepareDefault dflags env case_bndr' mb_tc_app imposs_deflt_cons maybe_deflt ; let trimmed_alts = filterOut impossible_alt alts_wo_default @@ -1289,7 +1289,7 @@ combineIdenticalAlts case_bndr alts = return alts -- Prepare the default alternative ------------------------------------------------------------------------- prepareDefault :: DynFlags - -> OutExpr -- Scrutinee + -> SimplEnv -> OutId -- Case binder; need just for its type. Note that as an -- OutId, it has maximum information; this is important. -- Test simpl013 is an example @@ -1301,10 +1301,16 @@ prepareDefault :: DynFlags -- And becuase case-merging can cause many to show up ------- Merge nested cases ---------- -prepareDefault dflags scrut outer_bndr bndr_ty imposs_cons (Just deflt_rhs) +prepareDefault dflags env outer_bndr bndr_ty imposs_cons (Just deflt_rhs) | dopt Opt_CaseMerge dflags - , Case (Var scrut_var) inner_bndr _ inner_alts <- deflt_rhs - , scruting_same_var scrut_var + , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs + , DoneId inner_scrut_var' <- substId env inner_scrut_var + -- Remember, inner_scrut_var is an InId, but outer_bndr is an OutId + , inner_scrut_var' == outer_bndr + -- NB: the substId means that if the outer scrutinee was a + -- variable, and inner scrutinee is the same variable, + -- then inner_scrut_var' will be outer_bndr + -- via the magic of simplCaseBinder = do { tick (CaseMerge outer_bndr) ; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs @@ -1324,17 +1330,10 @@ prepareDefault dflags scrut outer_bndr bndr_ty imposs_cons (Just deflt_rhs) -- mkCase applied to them, so they won't have a case in their default -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr -- in munge_rhs may put a case into the DEFAULT branch! - where - -- We are scrutinising the same variable if it's - -- the outer case-binder, or if the outer case scrutinises a variable - -- (and it's the same). Testing both allows us not to replace the - -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder). - scruting_same_var = case scrut of - Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut - other -> \ v -> v == outer_bndr + --------- Fill in known constructor ----------- -prepareDefault dflags scrut case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) +prepareDefault dflags env case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) | -- This branch handles the case where we are -- scrutinisng an algebraic data type isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. @@ -1368,10 +1367,10 @@ prepareDefault dflags scrut case_bndr (Just (tycon, inst_tys)) imposs_cons (Just two_or_more -> return [(DEFAULT, [], deflt_rhs)] --------- Catch-all cases ----------- -prepareDefault dflags scrut case_bndr bndr_ty imposs_cons (Just deflt_rhs) +prepareDefault dflags env case_bndr bndr_ty imposs_cons (Just deflt_rhs) = return [(DEFAULT, [], deflt_rhs)] -prepareDefault dflags scrut case_bndr bndr_ty imposs_cons Nothing +prepareDefault dflags env case_bndr bndr_ty imposs_cons Nothing = return [] -- No default branch \end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 89c5fb1..dbad116 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1467,7 +1467,7 @@ simplCaseBinder env scrut case_bndr alts -- See Note [no-case-of-case] = (env, case_bndr) - | otherwise -- Failed try [see Note 2 above] + | otherwise -- Failed try; see Note [Suppressing the case binder-swap] -- not (isEvaldUnfolding (idUnfolding v)) = case scrut of Var v -> (modifyInScope env1 v case_bndr', case_bndr') @@ -1545,7 +1545,7 @@ simplAlts env scrut case_bndr alts cont' do { let alt_env = zapFloats env ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts - ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts + ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env scrut case_bndr' alts ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts ; return (scrut', case_bndr', alts') } -- 1.7.10.4