diff options
author | Simon Peyton Jones <simon.peytonjones@gmail.com> | 2023-01-28 22:12:35 +0000 |
---|---|---|
committer | Matthew Pickering <matthewtpickering@gmail.com> | 2023-02-20 09:43:59 +0000 |
commit | 21ccdbac2844a39bd67096b70650cd0c1ab0919c (patch) | |
tree | ef6d91604a014f009f221e1a2b38e52be5e48098 | |
parent | 6c2b992438609e7d5d4066cc3e0929e6aeecca7b (diff) | |
download | haskell-21ccdbac2844a39bd67096b70650cd0c1ab0919c.tar.gz |
Treat existentials correctly in dubiousDataConInstArgTys
Consider (#22849)
data T a where
MkT :: forall k (t::k->*) (ix::k). t ix -> T @k a
Then dubiousDataConInstArgTys MkT [Type, Foo] should return
[Foo (ix::Type)]
NOT [Foo (ix::k)]
A bit of an obscure case, but it's an outright bug, and the fix is easy.
(cherry picked from commit 955a99ea28a0d06de67f0595d366450281aab0c0)
-rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 25 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T22849.hs | 14 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 2 |
3 files changed, 32 insertions, 9 deletions
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index f599975355..488eeaf5f4 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -707,7 +707,7 @@ Worker/wrapper will unbox * is an algebraic data type (not a newtype) * is not recursive (as per 'isRecDataCon') * has a single constructor (thus is a "product") - * that may bind existentials + * that may bind existentials (#18982) We can transform > data D a = forall b. D a b > f (D @ex a b) = e @@ -1272,16 +1272,25 @@ also unbox its components. That is governed by the `usefulSplit` mechanism. -} -- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that --- the 'DataCon' may not have existentials. The lack of cloning the existentials --- compared to 'dataConInstExAndArgVars' makes this function \"dubious\"; --- only use it where type variables aren't substituted for! +-- the 'DataCon' may not have existentials. The lack of cloning the +-- existentials this function \"dubious\"; only use it where type variables +-- aren't substituted for! Why may the data con bind existentials? +-- See Note [Which types are unboxed?] dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type] dubiousDataConInstArgTys dc tc_args = arg_tys where - univ_tvs = dataConUnivTyVars dc - ex_tvs = dataConExTyCoVars dc - subst = extendSubstInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs - arg_tys = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc) + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyCoVars dc + univ_subst = zipTvSubst univ_tvs tc_args + (full_subst, _) = substTyVarBndrs univ_subst ex_tvs + arg_tys = map (substTy full_subst . scaledThing) $ + dataConRepArgTys dc + -- NB: use substTyVarBndrs on ex_tvs to ensure that we + -- substitute in their kinds. For example (#22849) + -- Consider data T a where + -- MkT :: forall k (t::k->*) (ix::k). t ix -> T @k a + -- Then dubiousDataConInstArgTys MkT [Type, Foo] should return + -- [Foo (ix::Type)], not [Foo (ix::k)]! findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type diff --git a/testsuite/tests/simplCore/should_compile/T22849.hs b/testsuite/tests/simplCore/should_compile/T22849.hs new file mode 100644 index 0000000000..a4c5179251 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T22849.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs #-} + +module T22849 where + +data Foo a where + Foo :: Foo Int + +data Bar a = Bar a (Foo a) + +data Some t = forall ix. Some (t ix) + +instance Show (Some Bar) where + show (Some (Bar v t)) = case t of + Foo -> show v diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 80a1f87477..d494a7ade0 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -452,7 +452,7 @@ test('T22375', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeab test('T21851_2', [grep_errmsg(r'wwombat') ], multimod_compile, ['T21851_2', '-O -dno-typeable-binds -dsuppress-uniques']) # Should not inline m, so there shouldn't be a single YES test('T22317', [grep_errmsg(r'ANSWER = YES') ], compile, ['-O -dinline-check m -ddebug-output']) - +test('T22849', normal, compile, ['-O']) test('T22634', normal, compile, ['-O -fcatch-nonexhaustive-cases']) test('T22494', [grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-uniques']) test('T22491', normal, compile, ['-O2']) |