From ece092d07f343dcfb4563e4f42d53a2a1e449f1a Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 21 Feb 2023 12:17:44 +0000 Subject: 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]. --- compiler/GHC/Core/Opt/Simplify/Iteration.hs | 6 ++-- compiler/GHC/Core/Opt/Simplify/Utils.hs | 33 ++++++++++++++-------- testsuite/tests/simplCore/should_compile/T23012.hs | 30 ++++++++++++++++++++ testsuite/tests/simplCore/should_compile/all.T | 1 + 4 files changed, 57 insertions(+), 13 deletions(-) create mode 100644 testsuite/tests/simplCore/should_compile/T23012.hs 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']) -- cgit v1.2.1