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!

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 1b05737..d0240fb 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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') }