Add a missing guard in GHC.HsToCore.Utils.is_flat_prod_patwip/T21519

This missing guard gave rise to #21519.

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, [''])