[Git][ghc/ghc][master] Introduce isBoxedTupleDataCon and use it to fix #18644
Marge Bot
gitlab at gitlab.haskell.org
Fri Sep 4 20:25:43 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c1e54439 by Ryan Scott at 2020-09-04T16:25:35-04:00
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.
- - - - -
18 changed files:
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/DataCon.hs-boot
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/CoreToByteCode.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/HsToCore/PmCheck/Ppr.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToCmm/DataCon.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/Types/Id.hs
- + testsuite/tests/ghci/scripts/T18644.script
- + testsuite/tests/ghci/scripts/T18644.stdout
- testsuite/tests/ghci/scripts/all.T
Changes:
=====================================
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
=====================================
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
=====================================
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
=====================================
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.
=====================================
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
=====================================
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
=====================================
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))
=====================================
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))
=====================================
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 )
=====================================
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
=====================================
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)
=====================================
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)
=====================================
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)
=====================================
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 }
=====================================
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]
=====================================
testsuite/tests/ghci/scripts/T18644.script
=====================================
@@ -0,0 +1,3 @@
+:set -XDataKinds -XUnboxedTuples
+:kind! '(# #)
+:kind! '()
=====================================
testsuite/tests/ghci/scripts/T18644.stdout
=====================================
@@ -0,0 +1,4 @@
+'(# #) :: (# #)
+= '(# #)
+'() :: ()
+= '()
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1e54439be3d38a1f972ac772cca7eec5e1519a9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1e54439be3d38a1f972ac772cca7eec5e1519a9
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200904/914c6b01/attachment-0001.html>
More information about the ghc-commits
mailing list