summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2020-09-02 18:45:05 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-09-04 16:25:35 -0400
commitc1e54439be3d38a1f972ac772cca7eec5e1519a9 (patch)
treefae78006b08e1cd756c41f7a09ec5bfb992da89c
parent220ad8d67af345cf3decf82ff26c1e696d21ac93 (diff)
downloadhaskell-c1e54439be3d38a1f972ac772cca7eec5e1519a9.tar.gz
Introduce isBoxedTupleDataCon and use it to fix #18644
The code that converts promoted tuple data constructors to `IfaceType`s in `GHC.CoreToIface` was using `isTupleDataCon`, which conflates boxed and unboxed tuple data constructors. To avoid this, this patch introduces `isBoxedTupleDataCon`, which is like `isTupleDataCon` but only works for _boxed_ tuple data constructors. While I was in town, I was horribly confused by the fact that there were separate functions named `isUnboxedTupleCon` and `isUnboxedTupleTyCon` (similarly, `isUnboxedSumCon` and `isUnboxedSumTyCon`). It turns out that the former only works for data constructors, despite its very general name! I opted to rename `isUnboxedTupleCon` to `isUnboxedTupleDataCon` (similarly, I renamed `isUnboxedSumCon` to `isUnboxedSumDataCon`) to avoid this potential confusion, as well as to be more consistent with the naming convention I used for `isBoxedTupleDataCon`. Fixes #18644.
-rw-r--r--compiler/GHC/Core/DataCon.hs16
-rw-r--r--compiler/GHC/Core/DataCon.hs-boot2
-rw-r--r--compiler/GHC/Core/Opt/DmdAnal.hs2
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs4
-rw-r--r--compiler/GHC/Core/TyCon.hs4
-rw-r--r--compiler/GHC/Core/Unfold.hs2
-rw-r--r--compiler/GHC/CoreToByteCode.hs8
-rw-r--r--compiler/GHC/CoreToIface.hs2
-rw-r--r--compiler/GHC/CoreToStg.hs2
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Ppr.hs2
-rw-r--r--compiler/GHC/Stg/Lint.hs4
-rw-r--r--compiler/GHC/Stg/Unarise.hs6
-rw-r--r--compiler/GHC/StgToCmm/DataCon.hs2
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs2
-rw-r--r--compiler/GHC/Types/Id.hs2
-rw-r--r--testsuite/tests/ghci/scripts/T18644.script3
-rw-r--r--testsuite/tests/ghci/scripts/T18644.stdout4
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T1
18 files changed, 40 insertions, 28 deletions
diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs
index 59152b5447..9b79ae8b7f 100644
--- a/compiler/GHC/Core/DataCon.hs
+++ b/compiler/GHC/Core/DataCon.hs
@@ -51,8 +51,9 @@ module GHC.Core.DataCon (
splitDataProductType_maybe,
-- ** Predicates on DataCons
- isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
- isUnboxedSumCon,
+ isNullarySrcDataCon, isNullaryRepDataCon,
+ isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon,
+ isUnboxedSumDataCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
dataConUserTyVarsArePermuted,
isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
@@ -1467,11 +1468,14 @@ dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat
isTupleDataCon :: DataCon -> Bool
isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
-isUnboxedTupleCon :: DataCon -> Bool
-isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc
+isBoxedTupleDataCon :: DataCon -> Bool
+isBoxedTupleDataCon (MkData {dcRepTyCon = tc}) = isBoxedTupleTyCon tc
-isUnboxedSumCon :: DataCon -> Bool
-isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc
+isUnboxedTupleDataCon :: DataCon -> Bool
+isUnboxedTupleDataCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc
+
+isUnboxedSumDataCon :: DataCon -> Bool
+isUnboxedSumDataCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc
-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors
isVanillaDataCon :: DataCon -> Bool
diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot
index 6df12da9db..f8807bf3a6 100644
--- a/compiler/GHC/Core/DataCon.hs-boot
+++ b/compiler/GHC/Core/DataCon.hs-boot
@@ -26,7 +26,7 @@ dataConInstOrigArgTys :: DataCon -> [Type] -> [Scaled Type]
dataConStupidTheta :: DataCon -> ThetaType
dataConFullSig :: DataCon
-> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type)
-isUnboxedSumCon :: DataCon -> Bool
+isUnboxedSumDataCon :: DataCon -> Bool
instance Eq DataCon
instance Uniquable DataCon
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 386a417cf9..083566ac78 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -359,7 +359,7 @@ forcesRealWorld fam_envs ty
= True
| Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys }
<- deepSplitProductType_maybe fam_envs ty
- , isUnboxedTupleCon dc
+ , isUnboxedTupleDataCon dc
= any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys
| otherwise
= False
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 795605c557..9ae25ad8f8 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -34,7 +34,7 @@ import GHC.Core.Coercion.Opt ( optCoercion )
import GHC.Core.FamInstEnv ( topNormaliseType_maybe )
import GHC.Core.DataCon
( DataCon, dataConWorkId, dataConRepStrictness
- , dataConRepArgTys, isUnboxedTupleCon
+ , dataConRepArgTys, isUnboxedTupleDataCon
, StrictnessMark (..) )
import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
import GHC.Core
@@ -2957,7 +2957,7 @@ addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]
addEvals scrut con vs
-- Deal with seq# applications
| Just scr <- scrut
- , isUnboxedTupleCon con
+ , isUnboxedTupleDataCon con
, [s,x] <- vs
-- Use stripNArgs rather than collectArgsTicks to avoid building
-- a list of arguments only to throw it away immediately.
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index e1b85969e3..f4211fac5e 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -148,7 +148,7 @@ import {-# SOURCE #-} GHC.Builtin.Types
import {-# SOURCE #-} GHC.Core.DataCon
( DataCon, dataConExTyCoVars, dataConFieldLabels
, dataConTyCon, dataConFullSig
- , isUnboxedSumCon )
+ , isUnboxedSumDataCon )
import GHC.Builtin.Uniques
( tyConRepNameUnique
, dataConTyRepNameUnique )
@@ -1323,7 +1323,7 @@ tyConRepName_maybe (AlgTyCon { algTcParent = parent })
tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })
= Just rep_nm
tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })
- | isUnboxedSumCon dc -- see #13276
+ | isUnboxedSumDataCon dc -- see #13276
= Nothing
| otherwise
= Just rep_nm
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 4792545df7..ea778f5a2d 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -889,7 +889,7 @@ conSize dc n_val_args
| n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables
-- See Note [Unboxed tuple size and result discount]
- | isUnboxedTupleCon dc = SizeIs 0 emptyBag 10
+ | isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10
-- See Note [Constructor size and result discount]
| otherwise = SizeIs 10 emptyBag 10
diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs
index 239152c059..051abd4d8b 100644
--- a/compiler/GHC/CoreToByteCode.hs
+++ b/compiler/GHC/CoreToByteCode.hs
@@ -648,7 +648,7 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
-- handle pairs with one void argument (e.g. state token)
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
- | isUnboxedTupleCon dc
+ | isUnboxedTupleDataCon dc
-- Convert
-- case .... of x { (# V'd-thing, a #) -> ... }
-- to
@@ -667,7 +667,7 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
-- handle unit tuples
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
- | isUnboxedTupleCon dc
+ | isUnboxedTupleDataCon dc
, typePrimRep (idType bndr) `lengthAtMost` 1
= doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
@@ -825,7 +825,7 @@ schemeT d s p app
-- Case 2: Constructor application
| Just con <- maybe_saturated_dcon
- , isUnboxedTupleCon con
+ , isUnboxedTupleDataCon con
= case args_r_to_l of
[arg1,arg2] | isVAtom arg1 ->
unboxedTupleReturn d s p arg2
@@ -1090,7 +1090,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
my_discr (DataAlt dc, _, _)
- | isUnboxedTupleCon dc || isUnboxedSumCon dc
+ | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
= multiValException
| otherwise
= DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index f9a11fe716..a65e89853c 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -188,7 +188,7 @@ toIfaceTypeX fr (TyConApp tc tys)
= IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys)
| Just dc <- isPromotedDataCon_maybe tc
- , isTupleDataCon dc
+ , isBoxedTupleDataCon dc
, n_tys == 2*arity
= IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 1abeb56fb7..2361a041d3 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -699,7 +699,7 @@ mkTopStgRhs dflags this_mod ccs bndr rhs
, -- Dynamic StgConApps are updatable
not (isDllConApp dflags this_mod con args)
= -- CorePrep does this right, but just to make sure
- ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
+ ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)
, ppr bndr $$ ppr con $$ ppr args)
( StgRhsCon dontCareCCS con args, ccs )
diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs
index 99ec5de4af..dc1739908f 100644
--- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs
@@ -172,7 +172,7 @@ pprConLike delta _prec cl args
WcVarTerminated pref x ->
parens . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])
pprConLike _delta _prec (RealDataCon con) args
- | isUnboxedTupleCon con
+ | isUnboxedTupleDataCon con
, let hash_parens doc = text "(#" <+> doc <+> text "#)"
= hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args
| isTupleDataCon con
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 206dd39187..2ce2c9b4d1 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -164,7 +164,7 @@ lintStgRhs (StgRhsClosure _ _ _ binders expr)
lintStgExpr expr
lintStgRhs rhs@(StgRhsCon _ con args) = do
- when (isUnboxedTupleCon con || isUnboxedSumCon con) $ do
+ when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
opts <- getStgPprOpts
addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
pprStgRhs opts rhs)
@@ -182,7 +182,7 @@ lintStgExpr (StgApp fun args) = do
lintStgExpr app@(StgConApp con args _arg_tys) = do
-- unboxed sums should vanish during unarise
lf <- getLintFlags
- when (lf_unarised lf && isUnboxedSumCon con) $ do
+ when (lf_unarised lf && isUnboxedSumDataCon con) $ do
opts <- getStgPprOpts
addErrL (text "Unboxed sum after unarise:" $$
pprStgExpr opts app)
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index 85c022f799..084c797136 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -294,7 +294,7 @@ unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
return (StgRhsClosure ext ccs update_flag args1 expr')
unariseRhs rho (StgRhsCon ccs con args)
- = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
+ = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
return (StgRhsCon ccs con (unariseConArgs rho args))
--------------------------------------------------------------------------------
@@ -372,10 +372,10 @@ unariseExpr rho (StgTick tick e)
-- Doesn't return void args.
unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe rho dc args ty_args
- | isUnboxedTupleCon dc
+ | isUnboxedTupleDataCon dc
= Just (unariseConArgs rho args)
- | isUnboxedSumCon dc
+ | isUnboxedSumDataCon dc
, let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)
= Just (mkUbxSum dc ty_args args1)
diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs
index 8e11bffad3..681f1461f1 100644
--- a/compiler/GHC/StgToCmm/DataCon.hs
+++ b/compiler/GHC/StgToCmm/DataCon.hs
@@ -354,7 +354,7 @@ bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
-- binders args, assuming that we have just returned from a 'case' which
-- found a con
bindConArgs (DataAlt con) base args
- = ASSERT(not (isUnboxedTupleCon con))
+ = ASSERT(not (isUnboxedTupleDataCon con))
do profile <- getProfile
platform <- getPlatform
let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 72f8941740..f6c8176a92 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -837,7 +837,7 @@ maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =
cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind
cgConApp con stg_args
- | isUnboxedTupleCon con -- Unboxed tuple: assign and return
+ | isUnboxedTupleDataCon con -- Unboxed tuple: assign and return
= do { arg_exprs <- getNonVoidArgAmodes stg_args
; tickyUnboxedTupleReturn (length arg_exprs)
; emitReturn arg_exprs }
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 5b6c54cc00..2d6198dd64 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -556,7 +556,7 @@ hasNoBinding :: Id -> Bool
hasNoBinding id = case Var.idDetails id of
PrimOpId _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps
FCallId _ -> True
- DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
+ DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
_ -> isCompulsoryUnfolding (idUnfolding id)
-- See Note [Levity-polymorphic Ids]
diff --git a/testsuite/tests/ghci/scripts/T18644.script b/testsuite/tests/ghci/scripts/T18644.script
new file mode 100644
index 0000000000..e1fb4a86d8
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T18644.script
@@ -0,0 +1,3 @@
+:set -XDataKinds -XUnboxedTuples
+:kind! '(# #)
+:kind! '()
diff --git a/testsuite/tests/ghci/scripts/T18644.stdout b/testsuite/tests/ghci/scripts/T18644.stdout
new file mode 100644
index 0000000000..704d4344b4
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T18644.stdout
@@ -0,0 +1,4 @@
+'(# #) :: (# #)
+= '(# #)
+'() :: ()
+= '()
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 0a05e1dffa..e9d40a7d68 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -315,3 +315,4 @@ test('T17403', normal, ghci_script, ['T17403.script'])
test('T17431', normal, ghci_script, ['T17431.script'])
test('T17549', normal, ghci_script, ['T17549.script'])
test('T17669', [extra_run_opts('-fexternal-interpreter -fobject-code'), expect_broken(17669)], ghci_script, ['T17669.script'])
+test('T18644', normal, ghci_script, ['T18644.script'])