Fix shadowing bug in prepareAlts

As #23012 showed, GHC.Core.Opt.Simplify.Utils.prepareAlts was
using an OutType to construct an InAlt.  When shadowing is in play,
this is outright wrong.

See Note [Shadowing in prepareAlts].

2 files changed, 26 insertions, 13 deletions

diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 5b757c0e35..c0ee65d320 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -3224,9 +3224,11 @@ simplAlts env0 scrut case_bndr alts cont'
         ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut
                                                        case_bndr case_bndr2 alts
 
-        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
+        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts
           -- NB: it's possible that the returned in_alts is empty: this is handled
-          -- by the caller (rebuildCase) in the missingAlt function
+          --     by the caller (rebuildCase) in the missingAlt function
+          -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts
+          --     See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils
 
         ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
 --      ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return ()
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 0a09183bf4..ffecebd876 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -2270,26 +2270,37 @@ h y = case y of
 If we inline h into f, the default case of the inlined h can't happen.
 If we don't notice this, we may end up filtering out *all* the cases
 of the inner case y, which give us nowhere to go!
+
+Note [Shadowing in prepareAlts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an
+/OutId/.  This is vital, because `refineDefaultAlt` uses `tys` to build
+a new /InAlt/.  If you pass an OutId, we'll end up appling the
+substitution twice: disaster (#23012).
+
+However this does mean that filling in the default alt might be
+delayed by a simplifier cycle, because an InId has less info than an
+OutId.  Test simplCore/should_compile/simpl013 apparently shows this
+up, although I'm not sure exactly how..
 -}
 
-prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
+prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
 -- The returned alternatives can be empty, none are possible
-prepareAlts scrut case_bndr' alts
-  | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr')
-           -- Case binder is needed just for its type. Note that as an
-           --   OutId, it has maximum information; this is important.
-           --   Test simpl013 is an example
+--
+-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts]
+prepareAlts scrut case_bndr alts
+  | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr)
   = do { us <- getUniquesM
-       ; let (idcs1, alts1)       = filterAlts tc tys imposs_cons alts
-             (yes2,  alts2)       = refineDefaultAlt us (idMult case_bndr') tc tys idcs1 alts1
-               -- the multiplicity on case_bndr's is the multiplicity of the
+       ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts
+             (yes2,  alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1
+               -- The multiplicity on case_bndr's is the multiplicity of the
                -- case expression The newly introduced patterns in
                -- refineDefaultAlt must be scaled by this multiplicity
              (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2
              -- "idcs" stands for "impossible default data constructors"
              -- i.e. the constructors that can't match the default case
-       ; when yes2 $ tick (FillInCaseDefault case_bndr')
-       ; when yes3 $ tick (AltMerge case_bndr')
+       ; when yes2 $ tick (FillInCaseDefault case_bndr)
+       ; when yes3 $ tick (AltMerge case_bndr)
        ; return (idcs3, alts3) }
 
   | otherwise  -- Not a data type, so nothing interesting happens