diff options
author | Simon Peyton Jones <simon.peytonjones@gmail.com> | 2022-05-10 20:00:01 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-05-11 20:07:27 -0400 |
commit | 32cdf62dc1537f572f2d044851e316ca37d8e012 (patch) | |
tree | b51dbb3aa6d8761f69a6d789646b470660016c1c | |
parent | dea9a3d90d657705be073fd4e0db64e76d717a0f (diff) | |
download | haskell-32cdf62dc1537f572f2d044851e316ca37d8e012.tar.gz |
Add a missing guard in GHC.HsToCore.Utils.is_flat_prod_pat
This missing guard gave rise to #21519.
-rw-r--r-- | compiler/GHC/Core/TyCon.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Utils.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_compile/T21519.hs | 18 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_compile/T21519a.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_compile/all.T | 2 |
5 files changed, 48 insertions, 1 deletions
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index ab30175cb2..e50751c2a0 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -52,6 +52,7 @@ module GHC.Core.TyCon( isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isUnboxedSumTyCon, isPromotedTupleTyCon, + isLiftedAlgTyCon, isTypeSynonymTyCon, mustBeSaturated, isPromotedDataCon, isPromotedDataCon_maybe, @@ -146,6 +147,8 @@ import {-# SOURCE #-} GHC.Core.DataCon ( DataCon, dataConFieldLabels , dataConTyCon, dataConFullSig , isUnboxedSumDataCon ) +import {-# SOURCE #-} GHC.Core.Type + ( isLiftedTypeKind ) import GHC.Builtin.Uniques ( tyConRepNameUnique , dataConTyRepNameUnique ) @@ -2360,6 +2363,11 @@ isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) = True isUnboxedSumTyCon _ = False +isLiftedAlgTyCon :: TyCon -> Bool +isLiftedAlgTyCon (AlgTyCon { tyConResKind = res_kind }) + = isLiftedTypeKind res_kind +isLiftedAlgTyCon _ = False + -- | Is this the 'TyCon' for a /promoted/ tuple? isPromotedTupleTyCon :: TyCon -> Bool isPromotedTupleTyCon tyCon diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index be165c80dd..b6725331a1 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -607,6 +607,7 @@ There are two cases. ------ Special case (B) ------- For a pattern that is essentially just a tuple: * A product type, so cannot fail + * Boxed, so that it can be matched lazily * Only one level, so that - generating multiple matches is fine - seq'ing it evaluates the same as matching it @@ -783,6 +784,7 @@ strip_bangs (L _ (BangPat _ p)) = strip_bangs p strip_bangs lp = lp is_flat_prod_lpat :: LPat GhcTc -> Bool +-- Pattern is equivalent to a flat, boxed, lifted tuple is_flat_prod_lpat = is_flat_prod_pat . unLoc is_flat_prod_pat :: Pat GhcTc -> Bool @@ -791,7 +793,9 @@ is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps is_flat_prod_pat (ConPat { pat_con = L _ pcon , pat_args = ps}) | RealDataCon con <- pcon - , Just _ <- tyConSingleDataCon_maybe (dataConTyCon con) + , let tc = dataConTyCon con + , Just _ <- tyConSingleDataCon_maybe tc + , isLiftedAlgTyCon tc = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False diff --git a/testsuite/tests/typecheck/should_compile/T21519.hs b/testsuite/tests/typecheck/should_compile/T21519.hs new file mode 100644 index 0000000000..aa88fefb91 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T21519.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +module T21519 where + +import GHC.Exts + +(# #) = (# #) + +g1 :: Bool -> (# Int #) +g1 = g1 + +f1 x = let (# a #) = g1 True in a + +g2 :: Bool -> (# #) +g2 = g2 + +f2 x = let (# #) = g2 True in True + diff --git a/testsuite/tests/typecheck/should_compile/T21519a.hs b/testsuite/tests/typecheck/should_compile/T21519a.hs new file mode 100644 index 0000000000..04a1d629e0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T21519a.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE UnliftedDatatypes, UnliftedNewtypes, MagicHash #-} +module T21519a where + +import GHC.Exts + +type T :: UnliftedType +data T = MkT Int +MkT _ = MkT 10 -- (1) + +f x = let MkT _ = MkT 10 in True + +newtype T2 = MkT2 Int# +MkT2 _ = MkT2 10# -- (2) + +g x = let MkT2 _ = MkT2 10# in True diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 1764ccb34b..4f546c0914 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -825,3 +825,5 @@ test('T21205', normal, compile, ['-O0']) test('T21323', normal, compile, ['']) test('T21315', normal, compile, ['-Wredundant-constraints']) test('T21516', normal, compile, ['']) +test('T21519', normal, compile, ['']) +test('T21519a', normal, compile, ['']) |