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!
\begin{code}
substId :: SimplEnv -> Id -> SimplSR
\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
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
where
-- Get the most up-to-date thing from the in-scope set
pattern in each alternative, so the binder-info is rather useful.
\begin{code}
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
= do { dflags <- getDOptsSmpl
; alts <- combineIdenticalAlts case_bndr' alts
-- EITHER by the context,
-- OR by a non-DEFAULT branch in this case expression.
-- 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
imposs_deflt_cons maybe_deflt
; let trimmed_alts = filterOut impossible_alt alts_wo_default
-- Prepare the default alternative
-------------------------------------------------------------------------
prepareDefault :: DynFlags
-- Prepare the default alternative
-------------------------------------------------------------------------
prepareDefault :: DynFlags
- -> OutExpr -- Scrutinee
-> 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
-> 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
-- And becuase case-merging can cause many to show up
------- Merge nested cases ----------
-- 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
| 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
= do { tick (CaseMerge outer_bndr)
; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) 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!
-- 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 -----------
--------- 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.
| -- This branch handles the case where we are
-- scrutinisng an algebraic data type
isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples.
two_or_more -> return [(DEFAULT, [], deflt_rhs)]
--------- Catch-all cases -----------
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)]
= 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}
= return [] -- No default branch
\end{code}
-- See Note [no-case-of-case]
= (env, case_bndr)
-- 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')
-- not (isEvaldUnfolding (idUnfolding v))
= case scrut of
Var v -> (modifyInScope env1 v case_bndr', case_bndr')
do { let alt_env = zapFloats env
; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts
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') }
; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts
; return (scrut', case_bndr', alts') }