Fix shadowing bug in prepareAltswip/T23012

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].

4 files changed, 57 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
diff --git a/testsuite/tests/simplCore/should_compile/T23012.hs b/testsuite/tests/simplCore/should_compile/T23012.hs
new file mode 100644
index 0000000000..7b0a42cac3
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23012.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE BangPatterns, FlexibleInstances, MultiParamTypeClasses #-}
+
+module T23012 where
+
+import Data.Kind (Type)
+
+class Vector v a where
+  nothing :: v a
+  just :: a -> v a
+
+data Proxy (a :: Type) = P
+
+instance Vector Proxy a where
+  nothing = P
+  just _ = P
+
+step :: Maybe a
+step = Nothing
+{-# INLINE[0] step #-}
+
+stream :: Vector v a => v a
+stream = case step of
+           Nothing -> nothing
+           Just !x -> just x
+{-# INLINE[1] stream #-}
+
+data Id a = MkId a
+
+f :: (Proxy (Id a), Proxy a)
+f = (stream, stream)
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 12e2ecf042..3f44a71732 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -472,5 +472,6 @@ test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-agg
 test('T22802', normal, compile, ['-O'])
 test('T15205', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
 test('T22761', normal, multimod_compile, ['T22761', '-O2 -v0'])
+test('T23012', normal, compile, ['-O'])
 
 test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])