diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Core/TyCon.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Utils.hs | 6 |
2 files changed, 13 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 |