summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simon.peytonjones@gmail.com>2022-05-10 20:00:01 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-05-11 20:07:27 -0400
commit32cdf62dc1537f572f2d044851e316ca37d8e012 (patch)
treeb51dbb3aa6d8761f69a6d789646b470660016c1c
parentdea9a3d90d657705be073fd4e0db64e76d717a0f (diff)
downloadhaskell-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.hs8
-rw-r--r--compiler/GHC/HsToCore/Utils.hs6
-rw-r--r--testsuite/tests/typecheck/should_compile/T21519.hs18
-rw-r--r--testsuite/tests/typecheck/should_compile/T21519a.hs15
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T2
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, [''])