diff options
author | Simon Peyton Jones <simon.peytonjones@gmail.com> | 2023-02-21 12:17:44 +0000 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2023-03-02 10:21:25 -0500 |
commit | 5451b48c5affeb443e2ba1eef60a9c10e0a5842b (patch) | |
tree | cbf880a11e97b4f1090d1d98efb2cbf87a9474bc | |
parent | 20dfcbedd0009d26266beac0f417ce80ae36b152 (diff) | |
download | haskell-5451b48c5affeb443e2ba1eef60a9c10e0a5842b.tar.gz |
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].
(cherry picked from commit ece092d07f343dcfb4563e4f42d53a2a1e449f1a)
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Iteration.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 33 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T23012.hs | 30 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
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 d8b95e7358..3ba61c9388 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -3194,9 +3194,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 6ecfce1442..cef65eb2b1 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -2266,26 +2266,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 1cd0665c11..da421159e1 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -464,4 +464,5 @@ test('T22725', normal, compile, ['-O']) test('T22662', normal, compile, ['']) test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively']) test('T22802', normal, compile, ['-O']) +test('T23012', normal, compile, ['-O']) test('T23024', normal, multimod_compile, ['T23024', '-O -v0']) |