diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2021-11-15 23:22:06 -0500 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-11-17 05:10:27 -0500 |
| commit | 083a7583d70c190b090fedcf9f955eff65d4baeb (patch) | |
| tree | 8706cc9ee591bf2a05c23efcaa7251a0489e4c24 | |
| parent | 3e94b5a7ebddf156f00599c6bd2e9ba1af437a6c (diff) | |
| download | haskell-083a7583d70c190b090fedcf9f955eff65d4baeb.tar.gz | |
Increase type sharing
Fixes #20541 by making mkTyConApp do more sharing of types.
In particular, replace
* BoxedRep Lifted ==> LiftedRep
* BoxedRep Unlifted ==> UnliftedRep
* TupleRep '[] ==> ZeroBitRep
* TYPE ZeroBitRep ==> ZeroBitType
In each case, the thing on the right is a type synonym
for the thing on the left, declared in ghc-prim:GHC.Types.
See Note [Using synonyms to compress types] in GHC.Core.Type.
The synonyms for ZeroBitRep and ZeroBitType are new, but absolutely
in the same spirit as the other ones. (These synonyms are mainly
for internal use, though the programmer can use them too.)
I also renamed GHC.Core.Ty.Rep.isVoidTy to isZeroBitTy, to be
compatible with the "zero-bit" nomenclature above. See discussion
on !6806.
There is a tricky wrinkle: see GHC.Core.Types
Note [Care using synonyms to compress types]
Compiler allocation decreases by up to 0.8%.
37 files changed, 488 insertions, 298 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 5b6f032bc5..1c689629f1 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -1877,7 +1877,8 @@ eitherTyConKey = mkPreludeTyConUnique 84 liftedTypeKindTyConKey, unliftedTypeKindTyConKey, tYPETyConKey, liftedRepTyConKey, unliftedRepTyConKey, constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey, - vecCountTyConKey, vecElemTyConKey :: Unique + vecCountTyConKey, vecElemTyConKey, + zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 87 unliftedTypeKindTyConKey = mkPreludeTyConUnique 88 tYPETyConKey = mkPreludeTyConUnique 89 @@ -1888,11 +1889,22 @@ vecCountTyConKey = mkPreludeTyConUnique 96 vecElemTyConKey = mkPreludeTyConUnique 97 liftedRepTyConKey = mkPreludeTyConUnique 98 unliftedRepTyConKey = mkPreludeTyConUnique 99 +zeroBitRepTyConKey = mkPreludeTyConUnique 100 +zeroBitTypeTyConKey = mkPreludeTyConUnique 101 pluginTyConKey, frontendPluginTyConKey :: Unique pluginTyConKey = mkPreludeTyConUnique 102 frontendPluginTyConKey = mkPreludeTyConUnique 103 +trTyConTyConKey, trModuleTyConKey, trNameTyConKey, + kindRepTyConKey, typeLitSortTyConKey :: Unique +trTyConTyConKey = mkPreludeTyConUnique 104 +trModuleTyConKey = mkPreludeTyConUnique 105 +trNameTyConKey = mkPreludeTyConUnique 106 +kindRepTyConKey = mkPreludeTyConUnique 107 +typeLitSortTyConKey = mkPreludeTyConUnique 108 + + -- Generics (Unique keys) v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, @@ -2092,21 +2104,14 @@ fingerprintDataConKey = mkPreludeDataConUnique 35 srcLocDataConKey :: Unique srcLocDataConKey = mkPreludeDataConUnique 37 -trTyConTyConKey, trTyConDataConKey, - trModuleTyConKey, trModuleDataConKey, - trNameTyConKey, trNameSDataConKey, trNameDDataConKey, - trGhcPrimModuleKey, kindRepTyConKey, - typeLitSortTyConKey :: Unique -trTyConTyConKey = mkPreludeDataConUnique 40 +trTyConDataConKey, trModuleDataConKey, + trNameSDataConKey, trNameDDataConKey, + trGhcPrimModuleKey :: Unique trTyConDataConKey = mkPreludeDataConUnique 41 -trModuleTyConKey = mkPreludeDataConUnique 42 trModuleDataConKey = mkPreludeDataConUnique 43 -trNameTyConKey = mkPreludeDataConUnique 44 trNameSDataConKey = mkPreludeDataConUnique 45 trNameDDataConKey = mkPreludeDataConUnique 46 trGhcPrimModuleKey = mkPreludeDataConUnique 47 -kindRepTyConKey = mkPreludeDataConUnique 48 -typeLitSortTyConKey = mkPreludeDataConUnique 49 typeErrorTextDataConKey, typeErrorAppendDataConKey, @@ -2143,13 +2148,19 @@ metaDataDataConKey = mkPreludeDataConUnique 68 metaConsDataConKey = mkPreludeDataConUnique 69 metaSelDataConKey = mkPreludeDataConUnique 70 -vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey, - boxedRepDataConKey :: Unique +vecRepDataConKey, sumRepDataConKey, + tupleRepDataConKey, boxedRepDataConKey :: Unique vecRepDataConKey = mkPreludeDataConUnique 71 tupleRepDataConKey = mkPreludeDataConUnique 72 sumRepDataConKey = mkPreludeDataConUnique 73 boxedRepDataConKey = mkPreludeDataConUnique 74 +boxedRepDataConTyConKey, tupleRepDataConTyConKey :: Unique +-- A promoted data constructors (i.e. a TyCon) has +-- the same key as the data constructor itself +boxedRepDataConTyConKey = boxedRepDataConKey +tupleRepDataConTyConKey = tupleRepDataConKey + -- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types -- Includes all nullary-data-constructor reps. Does not -- include BoxedRep, VecRep, SumRep, TupleRep. @@ -2208,6 +2219,7 @@ integerIPDataConKey = mkPreludeDataConUnique 122 naturalNSDataConKey = mkPreludeDataConUnique 123 naturalNBDataConKey = mkPreludeDataConUnique 124 + ---------------- Template Haskell ------------------- -- GHC.Builtin.Names.TH: USES DataUniques 200-250 ----------------------------------------------------- diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 1c587810ba..42cf6c3a4b 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -101,7 +101,7 @@ module GHC.Builtin.Types ( isLiftedTypeKindTyConName, typeToTypeKind, liftedRepTyCon, unliftedRepTyCon, - constraintKind, liftedTypeKind, unliftedTypeKind, + constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind, constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon, constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName, liftedRepTyConName, unliftedRepTyConName, @@ -115,7 +115,7 @@ module GHC.Builtin.Types ( runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon, boxedRepDataConTyCon, - runtimeRepTy, levityTy, liftedRepTy, unliftedRepTy, + runtimeRepTy, levityTy, liftedRepTy, unliftedRepTy, zeroBitRepTy, vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, @@ -207,18 +207,6 @@ alpha_ty :: [Type] alpha_ty = [alphaTy] {- -Note [Wiring in RuntimeRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, -making it a pain to wire in. To ease the pain somewhat, we use lists of -the different bits, like Uniques, Names, DataCons. These lists must be -kept in sync with each other. The rule is this: use the order as declared -in GHC.Types. All places where such lists exist should contain a reference -to this Note, so a search for this Note's name should find all the lists. - -See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. - - Note [Wired-in Types and Type Constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -324,6 +312,8 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they , integerTyCon , liftedRepTyCon , unliftedRepTyCon + , zeroBitRepTyCon + , zeroBitTypeTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -540,13 +530,15 @@ typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") constraintKindTyConName :: Name constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon -liftedTypeKindTyConName, unliftedTypeKindTyConName :: Name -liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon +liftedTypeKindTyConName, unliftedTypeKindTyConName, zeroBitTypeTyConName :: Name +liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") unliftedTypeKindTyConKey unliftedTypeKindTyCon +zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType") zeroBitTypeTyConKey zeroBitTypeTyCon -liftedRepTyConName, unliftedRepTyConName :: Name -liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") liftedRepTyConKey liftedRepTyCon +liftedRepTyConName, unliftedRepTyConName, zeroBitRepTyConName :: Name +liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") liftedRepTyConKey liftedRepTyCon unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") unliftedRepTyConKey unliftedRepTyCon +zeroBitRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep") zeroBitRepTyConKey zeroBitRepTyCon multiplicityTyConName :: Name multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity") @@ -757,10 +749,7 @@ constraintKindTyCon :: TyCon -- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon! constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] --- See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep. -liftedTypeKind, unliftedTypeKind, typeToTypeKind, constraintKind :: Kind -liftedTypeKind = mkTyConTy liftedTypeKindTyCon -unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon +typeToTypeKind, constraintKind :: Kind typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind constraintKind = mkTyConTy constraintKindTyCon @@ -1108,7 +1097,7 @@ cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZ -- [IntRep, LiftedRep])@ unboxedTupleSumKind :: TyCon -> [Type] -> Kind unboxedTupleSumKind tc rr_tys - = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) + = mkTYPEapp (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) -- | Specialization of 'unboxedTupleSumKind' for tuples unboxedTupleKind :: [Type] -> Kind @@ -1146,7 +1135,7 @@ mk_tuple Unboxed arity = (tycon, tuple_con) -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> TYPE (TupleRep [k1, k2]) tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) - (\ks -> map tYPE ks) + (\ks -> map mkTYPEapp ks) tc_res_kind = unboxedTupleKind rr_tys @@ -1224,13 +1213,13 @@ pairTyCon :: TyCon pairTyCon = tupleTyCon Boxed 2 unboxedUnitTy :: Type -unboxedUnitTy = mkTyConApp unboxedUnitTyCon [] +unboxedUnitTy = mkTyConTy unboxedUnitTyCon unboxedUnitTyCon :: TyCon unboxedUnitTyCon = tupleTyCon Unboxed 0 unboxedUnitDataCon :: DataCon -unboxedUnitDataCon = tupleDataCon Unboxed 0 +unboxedUnitDataCon = tupleDataCon Unboxed 0 {- ********************************************************************* @@ -1308,7 +1297,7 @@ mk_sum arity = (tycon, sum_cons) UnboxedSumTyCon tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) - (\ks -> map tYPE ks) + (\ks -> map mkTYPEapp ks) tyvars = binderVars tc_binders @@ -1472,67 +1461,163 @@ unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] un binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) , Bndr runtimeRep2TyVar (NamedTCB Inferred) ] - ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty - , tYPE runtimeRep2Ty + ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty + , mkTYPEapp runtimeRep2Ty ] unrestrictedFunTyConName :: Name -unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") unrestrictedFunTyConKey unrestrictedFunTyCon +unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") + unrestrictedFunTyConKey unrestrictedFunTyCon + {- ********************************************************************* * * - Kinds and RuntimeRep + Type synonyms (all declared in ghc-prim:GHC.Types) + + type Type = TYPE LiftedRep -- liftedTypeKind + type UnliftedType = TYPE UnliftedRep -- unliftedTypeKind + type LiftedRep = BoxedRep Lifted -- liftedRepTy + type UnliftedRep = BoxedRep Unlifted -- unliftedRepTy + * * ********************************************************************* -} --- For information about the usage of the following type, --- see Note [TYPE and RuntimeRep] in module GHC.Builtin.Types.Prim -runtimeRepTy, levityTy :: Type -runtimeRepTy = mkTyConTy runtimeRepTyCon -levityTy = mkTyConTy levityTyCon +-- For these synonyms, see +-- Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim, and +-- Note [Using synonyms to compress types] in GHC.Core.Type --- Type synonyms; see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim --- and Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep. --- +---------------------- -- @type Type = TYPE ('BoxedRep 'Lifted)@ liftedTypeKindTyCon :: TyCon -liftedTypeKindTyCon = - buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs - where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp liftedRepTyCon []] +liftedTypeKindTyCon + = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy] +liftedTypeKind :: Type +liftedTypeKind = mkTyConTy liftedTypeKindTyCon + +---------------------- -- | @type UnliftedType = TYPE ('BoxedRep 'Unlifted)@ unliftedTypeKindTyCon :: TyCon -unliftedTypeKindTyCon = - buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs - where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp unliftedRepTyCon []] +unliftedTypeKindTyCon + = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy] +unliftedTypeKind :: Type +unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon + +---------------------- +-- @type ZeroBitType = TYPE ZeroBitRep +zeroBitTypeTyCon :: TyCon +zeroBitTypeTyCon + = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy] + +zeroBitTypeKind :: Type +zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon + +---------------------- -- | @type LiftedRep = 'BoxedRep 'Lifted@ liftedRepTyCon :: TyCon -liftedRepTyCon = buildSynTyCon - liftedRepTyConName [] runtimeRepTy [] liftedRepTy +liftedRepTyCon + = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy] +liftedRepTy :: Type +liftedRepTy = mkTyConTy liftedRepTyCon + +---------------------- -- | @type UnliftedRep = 'BoxedRep 'Unlifted@ unliftedRepTyCon :: TyCon -unliftedRepTyCon = buildSynTyCon - unliftedRepTyConName [] runtimeRepTy [] unliftedRepTy +unliftedRepTyCon + = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy] -runtimeRepTyCon :: TyCon -runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] - (vecRepDataCon : tupleRepDataCon : - sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons) +unliftedRepTy :: Type +unliftedRepTy = mkTyConTy unliftedRepTyCon + +---------------------- +-- | @type ZeroBitRep = 'Tuple '[] +zeroBitRepTyCon :: TyCon +zeroBitRepTyCon + = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] + +zeroBitRepTy :: Type +zeroBitRepTy = mkTyConTy zeroBitRepTyCon + + +{- ********************************************************************* +* * + data Levity = Lifted | Unlifted +* * +********************************************************************* -} levityTyCon :: TyCon levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon] +levityTy :: Type +levityTy = mkTyConTy levityTyCon + liftedDataCon, unliftedDataCon :: DataCon liftedDataCon = pcSpecialDataCon liftedDataConName [] levityTyCon LiftedInfo unliftedDataCon = pcSpecialDataCon unliftedDataConName [] levityTyCon UnliftedInfo +liftedDataConTyCon :: TyCon +liftedDataConTyCon = promoteDataCon liftedDataCon + +unliftedDataConTyCon :: TyCon +unliftedDataConTyCon = promoteDataCon unliftedDataCon + +liftedDataConTy :: Type +liftedDataConTy = mkTyConTy liftedDataConTyCon + +unliftedDataConTy :: Type +unliftedDataConTy = mkTyConTy unliftedDataConTyCon + + +{- ********************************************************************* +* * + See Note [Wiring in RuntimeRep] + data RuntimeRep = VecRep VecCount VecElem + | TupleRep [RuntimeRep] + | SumRep [RuntimeRep] + | BoxedRep Levity + | IntRep | Int8Rep | ...etc... +* * +********************************************************************* -} + +{- Note [Wiring in RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, +making it a pain to wire in. To ease the pain somewhat, we use lists of +the different bits, like Uniques, Names, DataCons. These lists must be +kept in sync with each other. The rule is this: use the order as declared +in GHC.Types. All places where such lists exist should contain a reference +to this Note, so a search for this Note's name should find all the lists. + +See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. +-} + +runtimeRepTyCon :: TyCon +runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] + (vecRepDataCon : tupleRepDataCon : + sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons) + +runtimeRepTy :: Type +runtimeRepTy = mkTyConTy runtimeRepTyCon + boxedRepDataCon :: DataCon boxedRepDataCon = pcSpecialDataCon boxedRepDataConName - [ mkTyConTy levityTyCon ] runtimeRepTyCon (RuntimeRep prim_rep_fun) + [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) where -- See Note [Getting from RuntimeRep to PrimRep] in RepType prim_rep_fun [lev] @@ -1543,6 +1628,10 @@ boxedRepDataCon = pcSpecialDataCon boxedRepDataConName prim_rep_fun args = pprPanic "boxedRepDataCon" (ppr args) + +boxedRepDataConTyCon :: TyCon +boxedRepDataConTyCon = promoteDataCon boxedRepDataCon + vecRepDataCon :: DataCon vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon , mkTyConTy vecElemTyCon ] @@ -1669,30 +1758,6 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) vecElemDataCons - -liftedDataConTyCon :: TyCon -liftedDataConTyCon = promoteDataCon liftedDataCon - -unliftedDataConTyCon :: TyCon -unliftedDataConTyCon = promoteDataCon unliftedDataCon - -liftedDataConTy :: Type -liftedDataConTy = mkTyConTy liftedDataConTyCon - -unliftedDataConTy :: Type -unliftedDataConTy = mkTyConTy unliftedDataConTyCon - -boxedRepDataConTyCon :: TyCon -boxedRepDataConTyCon = promoteDataCon boxedRepDataCon - --- The type ('BoxedRep 'Lifted) -liftedRepTy :: Type -liftedRepTy = mkTyConApp boxedRepDataConTyCon [liftedDataConTy] - --- The type ('BoxedRep 'Unlifted) -unliftedRepTy :: Type -unliftedRepTy = mkTyConApp boxedRepDataConTyCon [unliftedDataConTy] - {- ********************************************************************* * * The boxed primitive types: Char, Int, etc @@ -1735,7 +1800,7 @@ charDataCon :: DataCon charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon stringTy :: Type -stringTy = mkTyConApp stringTyCon [] +stringTy = mkTyConTy stringTyCon stringTyCon :: TyCon -- We have this wired-in so that Haskell literal strings diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot index 73b6fc16fe..a8b499013a 100644 --- a/compiler/GHC/Builtin/Types.hs-boot +++ b/compiler/GHC/Builtin/Types.hs-boot @@ -16,27 +16,24 @@ coercibleTyCon, heqTyCon :: TyCon unitTy :: Type + liftedTypeKindTyConName :: Name -liftedTypeKind :: Kind -unliftedTypeKind :: Kind +liftedTypeKind, unliftedTypeKind, zeroBitTypeKind :: Kind -liftedTypeKindTyCon :: TyCon -unliftedTypeKindTyCon :: TyCon +liftedTypeKindTyCon, unliftedTypeKindTyCon :: TyCon -liftedRepTyCon :: TyCon -unliftedRepTyCon :: TyCon +liftedRepTyCon, unliftedRepTyCon :: TyCon constraintKind :: Kind runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon :: TyCon runtimeRepTy, levityTy :: Type -boxedRepDataConTyCon :: TyCon -liftedDataConTyCon :: TyCon +boxedRepDataConTyCon, liftedDataConTyCon :: TyCon vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -liftedRepTy, unliftedRepTy :: Type +liftedRepTy, unliftedRepTy, zeroBitRepTy :: Type liftedDataConTy, unliftedDataConTy :: Type intRepDataConTy, diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 32ceb36a2d..7ba9023f25 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -46,7 +46,7 @@ module GHC.Builtin.Types.Prim( tYPETyCon, tYPETyConName, -- Kinds - tYPE, primRepToRuntimeRep, primRepsToRuntimeRep, + mkTYPEapp, primRepToRuntimeRep, primRepsToRuntimeRep, functionWithMultiplicity, funTyCon, funTyConName, @@ -113,7 +113,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind , boxedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon - , liftedRepTy, unliftedRepTy + , liftedRepTy, unliftedRepTy, zeroBitRepTy , intRepDataConTy , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy , wordRepDataConTy @@ -142,7 +142,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid -- import loops which show up if you import Type instead -import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, tYPE ) +import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, mkTYPEapp ) import Data.Char @@ -400,7 +400,7 @@ alphaTy, betaTy, gammaTy, deltaTy :: Type (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys alphaTyVarsUnliftedRep :: [TyVar] -alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepTy) +alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (mkTYPEapp unliftedRepTy) alphaTyVarUnliftedRep :: TyVar (alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep @@ -427,7 +427,7 @@ openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar -- beta :: TYPE r2 -- gamma :: TYPE r3 [openAlphaTyVar,openBetaTyVar,openGammaTyVar] - = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty, tYPE runtimeRep3Ty] + = mkTemplateTyVars [mkTYPEapp runtimeRep1Ty, mkTYPEapp runtimeRep2Ty, mkTYPEapp runtimeRep3Ty] openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec :: TyVarBinder openAlphaTyVarSpec = mkTyVarBinder Specified openAlphaTyVar @@ -456,8 +456,8 @@ levity2Ty = mkTyVarTy levity2TyVar levPolyAlphaTyVar, levPolyBetaTyVar :: TyVar [levPolyAlphaTyVar, levPolyBetaTyVar] = mkTemplateTyVars - [tYPE (mkTyConApp boxedRepDataConTyCon [levity1Ty]) - ,tYPE (mkTyConApp boxedRepDataConTyCon [levity2Ty])] + [mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity1Ty]) + ,mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity2Ty])] -- alpha :: TYPE ('BoxedRep l) -- beta :: TYPE ('BoxedRep k) @@ -513,8 +513,8 @@ funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1 , mkNamedTyConBinder Inferred runtimeRep1TyVar , mkNamedTyConBinder Inferred runtimeRep2TyVar ] - ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty - , tYPE runtimeRep2Ty + ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty + , mkTYPEapp runtimeRep2Ty ] tc_rep_nm = mkPrelTyConRepName funTyConName @@ -651,13 +651,13 @@ pcPrimTyCon name roles rep = mkPrimTyCon name binders result_kind roles where binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) - result_kind = tYPE (primRepToRuntimeRep rep) + result_kind = mkTYPEapp (primRepToRuntimeRep rep) -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep -- Defined here to avoid (more) module loops primRepToRuntimeRep :: PrimRep -> Type primRepToRuntimeRep rep = case rep of - VoidRep -> mkTupleRep [] + VoidRep -> zeroBitRepTy LiftedRep -> liftedRepTy UnliftedRep -> unliftedRepTy IntRep -> intRepDataConTy diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 7e3b472a95..899ba20fb0 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1272,13 +1272,12 @@ lintTyApp fun_ty arg_ty lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv) lintValApp arg fun_ty arg_ty fun_ue arg_ue | Just (w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty - = do { ensureEqTys arg_ty' arg_ty err1 + = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) ; let app_ue = addUE fun_ue (scaleUE w arg_ue) ; return (res_ty', app_ue) } | otherwise = failWithL err2 where - err1 = mkAppMsg fun_ty arg_ty arg err2 = mkNonFunAppMsg fun_ty arg_ty arg lintTyKind :: OutTyVar -> LintedType -> LintM () @@ -3099,10 +3098,10 @@ mkNewTyDataConAltMsg scrut_ty alt -- Other error messages mkAppMsg :: Type -> Type -> CoreExpr -> SDoc -mkAppMsg fun_ty arg_ty arg +mkAppMsg expected_arg_ty actual_arg_ty arg = vcat [text "Argument value doesn't match argument type:", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Expected arg type:") 4 (ppr expected_arg_ty), + hang (text "Actual arg type:") 4 (ppr actual_arg_ty), hang (text "Arg:") 4 (ppr arg)] mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 8ce2eb857a..1398bfd6e7 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -932,7 +932,7 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs -- substitution will happen, since we are going to discard the binding else -- Keep the binding; do cast worker/wrapper - -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $ + -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $ tryCastWorkerWrapper env top_lvl old_bndr occ_info new_bndr_w_info eta_rhs } addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId @@ -1082,7 +1082,7 @@ simplExprC :: SimplEnv -> SimplM OutExpr -- Simplify an expression, given a continuation simplExprC env expr cont - = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $ + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $ do { (floats, expr') <- simplExprF env expr cont ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ @@ -3015,7 +3015,7 @@ simplAlts env0 scrut case_bndr alts cont' -- by the caller (rebuildCase) in the missingAlt function ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts - ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ +-- ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return () ; let alts_ty' = contResultType cont' -- See Note [Avoiding space leaks in OutType] diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index c2287916db..ce02f46e45 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -271,7 +271,7 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr only_one_void_argument | [d] <- demands , [v] <- filter isId arg_vars - , isAbsDmd d && isVoidTy (idType v) + , isAbsDmd d && isZeroBitTy (idType v) = True | otherwise = False diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index b9986e0a36..bb7280dd0d 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -42,7 +42,7 @@ module GHC.Core.TyCo.Rep ( MCoercion(..), MCoercionR, MCoercionN, -- * Functions over types - mkTyConTy_, mkTyVarTy, mkTyVarTys, + mkNakedTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkForAllTy, mkForAllTys, mkInvisForAllTys, @@ -1062,11 +1062,13 @@ mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty mkPiTys :: [TyCoBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs --- | Create a nullary 'TyConApp'. In general you should rather use --- 'GHC.Core.Type.mkTyConTy'. This merely exists to break the import cycle --- between 'GHC.Core.TyCon' and this module. -mkTyConTy_ :: TyCon -> Type -mkTyConTy_ tycon = TyConApp tycon [] +-- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you +-- should rather use 'GHC.Core.Type.mkTyConTy', which picks the shared +-- nullary TyConApp from inside the TyCon (via tyConNullaryTy. But +-- we have to build the TyConApp tc [] in that TyCon field; that's +-- what 'mkNakedTyConTy' is for. +mkNakedTyConTy :: TyCon -> Type +mkNakedTyConTy tycon = TyConApp tycon [] {- %************************************************************************ diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot index 0c89a2f077..f2e59d534f 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs-boot +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -24,7 +24,7 @@ type MCoercionN = MCoercion mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type mkForAllTy :: Var -> ArgFlag -> Type -> Type -mkTyConTy_ :: TyCon -> Type +mkNakedTyConTy :: TyCon -> Type instance Data Type -- To support Data instances in GHC.Core.Coercion.Axiom instance Outputable Type diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 5d060cb7cd..ec77cd2671 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -746,8 +746,8 @@ subst_ty subst ty go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys -- NB: mkTyConApp, not TyConApp. -- mkTyConApp has optimizations. - -- See Note [Prefer Type over TYPE 'LiftedRep] - -- in GHC.Core.TyCo.Rep + -- See Note [Using synonyms to compress types] + -- in GHC.Core.Type go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res }) = let !mult' = go mult !arg' = go arg diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index fd5b3df534..24807945cc 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -138,7 +138,7 @@ import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.Core.TyCo.Rep - ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkTyConTy_ ) + ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkNakedTyConTy ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) import {-# SOURCE #-} GHC.Builtin.Types @@ -1819,7 +1819,7 @@ So we compromise, and move their Kind calculation to the call site. -} -- | Given the name of the function type constructor and it's kind, create the --- corresponding 'TyCon'. It is recommended to use 'GHC.Core.TyCo.Rep.funTyCon' if you want +-- corresponding 'TyCon'. It is recommended to use 'GHC.Builtin.Types.funTyCon' if you want -- this functionality mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon mkFunTyCon name binders rep_nm @@ -1831,7 +1831,7 @@ mkFunTyCon name binders rep_nm tyConResKind = liftedTypeKind, tyConKind = mkTyConKind binders liftedTypeKind, tyConArity = length binders, - tyConNullaryTy = mkTyConTy_ tc, + tyConNullaryTy = mkNakedTyConTy tc, tcRepName = rep_nm } in tc @@ -1858,7 +1858,7 @@ mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = length binders, - tyConNullaryTy = mkTyConTy_ tc, + tyConNullaryTy = mkNakedTyConTy tc, tyConTyVars = binderVars binders, tcRoles = roles, tyConCType = cType, @@ -1897,7 +1897,7 @@ mkTupleTyCon name binders res_kind arity con sort parent tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = arity, - tyConNullaryTy = mkTyConTy_ tc, + tyConNullaryTy = mkNakedTyConTy tc, tcRoles = replicate arity Representational, tyConCType = Nothing, algTcGadtSyntax = False, @@ -1927,7 +1927,7 @@ mkSumTyCon name binders res_kind arity tyvars cons parent tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = arity, - tyConNullaryTy = mkTyConTy_ tc, + tyConNullaryTy = mkNakedTyConTy tc, tcRoles = replicate arity Representational, tyConCType = Nothing, algTcGadtSyntax = False, @@ -1962,7 +1962,7 @@ mkTcTyCon name binders res_kind scoped_tvs poly flav , tyConResKind = res_kind , tyConKind = mkTyConKind binders res_kind , tyConArity = length binders - , tyConNullaryTy = mkTyConTy_ tc + , tyConNullaryTy = mkNakedTyConTy tc , tcTyConScopedTyVars = scoped_tvs , tcTyConIsPoly = poly , tcTyConFlavour = flav } @@ -2013,7 +2013,7 @@ mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = length roles, - tyConNullaryTy = mkTyConTy_ tc, + tyConNullaryTy = mkNakedTyConTy tc, tcRoles = roles, isUnlifted = is_unlifted, primRepName = rep_nm @@ -2032,7 +2032,7 @@ mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = length binders, - tyConNullaryTy = mkTyConTy_ tc, + tyConNullaryTy = mkNakedTyConTy tc, tyConTyVars = binderVars binders, tcRoles = roles, synTcRhs = rhs, @@ -2055,7 +2055,7 @@ mkFamilyTyCon name binders res_kind resVar flav parent inj , tyConResKind = res_kind , tyConKind = mkTyConKind binders res_kind , tyConArity = length binders - , tyConNullaryTy = mkTyConTy_ tc + , tyConNullaryTy = mkNakedTyConTy tc , tyConTyVars = binderVars binders , famTcResVar = resVar , famTcFlav = flav @@ -2078,7 +2078,7 @@ mkPromotedDataCon con name rep_name binders res_kind roles rep_info tyConUnique = nameUnique name, tyConName = name, tyConArity = length roles, - tyConNullaryTy = mkTyConTy_ tc, + tyConNullaryTy = mkNakedTyConTy tc, tcRoles = roles, tyConBinders = binders, tyConResKind = res_kind, @@ -2468,7 +2468,7 @@ setTcTyConKind :: TyCon -> Kind -> TyCon -- kind, so we don't need to update any other fields. -- See Note [The Purely Kinded Invariant] in GHC.Tc.Gen.HsType setTcTyConKind tc@(TcTyCon {}) kind = let tc' = tc { tyConKind = kind - , tyConNullaryTy = mkTyConTy_ tc' + , tyConNullaryTy = mkNakedTyConTy tc' -- see Note [Sharing nullary TyCons] } in tc' diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 16688cf287..cf671657b0 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -36,7 +36,7 @@ module GHC.Core.Type ( splitFunTy, splitFunTy_maybe, splitFunTys, funResultTy, funArgTy, - mkTyConApp, mkTyConTy, tYPE, + mkTyConApp, mkTyConTy, mkTYPEapp, tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, tyConAppArgN, @@ -259,8 +259,8 @@ import GHC.Builtin.Types.Prim import {-# SOURCE #-} GHC.Builtin.Types ( charTy, naturalTy, listTyCon , typeSymbolKind, liftedTypeKind, unliftedTypeKind - , liftedRepTyCon, unliftedRepTyCon - , constraintKind + , liftedRepTy, unliftedRepTy, zeroBitRepTy + , constraintKind, zeroBitTypeKind , unrestrictedFunTyCon , manyDataConTy, oneDataConTy ) import GHC.Types.Name( Name ) @@ -290,6 +290,7 @@ import GHC.Types.Unique ( nonDetCmpUnique ) import GHC.Data.Maybe ( orElse, expectJust ) import Data.Maybe ( isJust ) import Control.Monad ( guard ) +-- import GHC.Utils.Trace -- $type_classification -- #type_classification# @@ -457,38 +458,58 @@ coreView _ = Nothing -- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a -- synonym. expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type -expandSynTyConApp_maybe tc tys +{-# INLINE expandSynTyConApp_maybe #-} +-- This INLINE will inline the call to expandSynTyConApp_maybe in coreView, +-- which will eliminate the allocat ion Just/Nothing in the result +-- Don't be tempted to make `expand_syn` (which is NOINLIN) return the +-- Just/Nothing, else you'll increase allocation +expandSynTyConApp_maybe tc arg_tys | Just (tvs, rhs) <- synTyConDefn_maybe tc - , tys `lengthAtLeast` arity - = Just (expand_syn arity tvs rhs tys) + , arg_tys `lengthAtLeast` (tyConArity tc) + = Just (expand_syn tvs rhs arg_tys) | otherwise = Nothing - where - arity = tyConArity tc --- Without this INLINE the call to expandSynTyConApp_maybe in coreView --- will result in an avoidable allocation. -{-# INLINE expandSynTyConApp_maybe #-} -- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path -- into call-sites. -expand_syn :: Int -- ^ the arity of the synonym - -> [TyVar] -- ^ the variables bound by the synonym +-- +-- Precondition: the call is saturated or over-saturated; +-- i.e. length tvs <= length arg_tys +expand_syn :: [TyVar] -- ^ the variables bound by the synonym -> Type -- ^ the RHS of the synonym -> [Type] -- ^ the type arguments the synonym is instantiated at. -> Type -expand_syn arity tvs rhs tys - | tys `lengthExceeds` arity = mkAppTys rhs' (drop arity tys) - | otherwise = rhs' +{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path. + +expand_syn tvs rhs arg_tys + -- No substitution necessary if either tvs or tys is empty + -- This is both more efficient, and steers clear of an infinite + -- loop; see Note [Care using synonyms to compress types] + | null arg_tys = assert (null tvs) rhs + | null tvs = mkAppTys rhs arg_tys + | otherwise = go empty_subst tvs arg_tys where - rhs' = substTy (mkTvSubstPrs (tvs `zip` tys)) rhs - -- The free vars of 'rhs' should all be bound by 'tenv', so it's - -- ok to use 'substTy' here (which is what expandSynTyConApp_maybe does). - -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. - -- Its important to use mkAppTys, rather than (foldl AppTy), - -- because the function part might well return a - -- partially-applied type constructor; indeed, usually will! --- We never want to inline this cold-path. -{-# INLINE expand_syn #-} + empty_subst = mkEmptyTCvSubst in_scope + in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys + -- The free vars of 'rhs' should all be bound by 'tenv', + -- so we only need the free vars of tys + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + + go subst [] tys + | null tys = rhs' -- Exactly Saturated + | otherwise = mkAppTys rhs' tys + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because the function part might well return a + -- partially-applied type constructor; indeed, usually will! + where + rhs' = substTy subst rhs + + go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys + + go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys) + -- Under-saturated, precondition failed + + coreFullView :: Type -> Type -- ^ Iterates 'coreView' until there is no more to synonym to expand. @@ -1635,55 +1656,137 @@ tyConBindersTyCoBinders = map to_tyb to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) to_tyb (Bndr tv (AnonTCB af)) = Anon af (tymult (varType tv)) --- | Create the plain type constructor type which has been applied to no type arguments at all. +-- | (mkTyConTy tc) returns (TyConApp tc []) +-- but arranges to share that TyConApp among all calls +-- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon mkTyConTy :: TyCon -> Type mkTyConTy tycon = tyConNullaryTy tycon - -- see Note [Sharing nullary TyConApps] in GHC.Core.TyCon -- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to -- its arguments. Applies its arguments to the constructor from left to right. mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | null tys - = mkTyConTy tycon - - | isFunTyCon tycon - , [w, _rep1,_rep2,ty1,ty2] <- tys - -- The FunTyCon (->) is always a visible one - = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 } - - -- See Note [Prefer Type over TYPE 'LiftedRep]. - | tycon `hasKey` tYPETyConKey - , [rep] <- tys - = tYPE rep +mkTyConApp tycon [] + = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon + mkTyConTy tycon + +mkTyConApp tycon tys@(ty1:rest) + | key == funTyConKey + = case tys of + [w, _rep1,_rep2,arg,res] -> FunTy { ft_af = VisArg, ft_mult = w + , ft_arg = arg, ft_res = res } + _ -> bale_out + + -- See Note [Using synonyms to compress types] + | key == tYPETyConKey + = assert (null rest) $ +-- mkTYPEapp_maybe ty1 `orElse` bale_out + case mkTYPEapp_maybe ty1 of + Just ty -> ty -- pprTrace "mkTYPEapp:yes" (ppr ty) ty + Nothing -> bale_out -- pprTrace "mkTYPEapp:no" (ppr bale_out) bale_out + + -- See Note [Using synonyms to compress types] + | key == boxedRepDataConTyConKey + = assert (null rest) $ +-- mkBoxedRepApp_maybe ty1 `orElse` bale_out + case mkBoxedRepApp_maybe ty1 of + Just ty -> ty -- pprTrace "mkBoxedRepApp:yes" (ppr ty) ty + Nothing -> bale_out -- pprTrace "mkBoxedRepApp:no" (ppr bale_out) bale_out + + | key == tupleRepDataConTyConKey + = case mkTupleRepApp_maybe ty1 of + Just ty -> ty -- pprTrace "mkTupleRepApp:yes" (ppr ty) ty + Nothing -> bale_out -- pprTrace "mkTupleRepApp:no" (ppr bale_out) bale_out + -- The catch-all case | otherwise - = TyConApp tycon tys + = bale_out + where + key = tyConUnique tycon + bale_out = TyConApp tycon tys + +mkTYPEapp :: Type -> Type +mkTYPEapp rr + = case mkTYPEapp_maybe rr of + Just ty -> ty + Nothing -> TyConApp tYPETyCon [rr] + +mkTYPEapp_maybe :: Type -> Maybe Type +-- ^ Given a @RuntimeRep@, applies @TYPE@ to it. +-- On the fly it rewrites +-- TYPE LiftedRep --> liftedTypeKind (a synonym) +-- TYPE UnliftedRep --> unliftedTypeKind (ditto) +-- TYPE ZeroBitRep --> zeroBitTypeKind (ditto) +-- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted) +-- because those inner types should already have been rewritten +-- to LiftedRep and UnliftedRep respectively, by mkTyConApp +-- +-- see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkTYPEapp_maybe #-} +mkTYPEapp_maybe (TyConApp tc args) + | key == liftedRepTyConKey = assert (null args) $ Just liftedTypeKind -- TYPE LiftedRep + | key == unliftedRepTyConKey = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep + | key == zeroBitRepTyConKey = assert (null args) $ Just zeroBitTypeKind -- TYPE ZeroBitRep + where + key = tyConUnique tc +mkTYPEapp_maybe _ = Nothing + +mkBoxedRepApp_maybe :: Type -> Maybe Type +-- ^ Given a `Levity`, apply `BoxedRep` to it +-- On the fly, rewrite +-- BoxedRep Lifted --> liftedRepTy (a synonym) +-- BoxedRep Unlifted --> unliftedRepTy (ditto) +-- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkBoxedRepApp_maybe #-} +mkBoxedRepApp_maybe (TyConApp tc args) + | key == liftedDataConKey = assert (null args) $ Just liftedRepTy -- BoxedRep Lifted + | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy -- BoxedRep Unlifted + where + key = tyConUnique tc +mkBoxedRepApp_maybe _ = Nothing -{- -Note [Prefer Type over TYPE 'LiftedRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Core of nearly any program will have numerous occurrences of -@TYPE 'LiftedRep@ (and, equivalently, 'Type') floating about. Concretely, while -investigating #17292 we found that these constituting a majority of TyConApp -constructors on the heap: - -``` -(From a sample of 100000 TyConApp closures) -0x45f3523 - 28732 - `Type` -0x420b840702 - 9629 - generic type constructors -0x42055b7e46 - 9596 -0x420559b582 - 9511 -0x420bb15a1e - 9509 -0x420b86c6ba - 9501 -0x42055bac1e - 9496 -0x45e68fd - 538 - `TYPE ...` -``` +mkTupleRepApp_maybe :: Type -> Maybe Type +-- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it +-- On the fly, rewrite +-- TupleRep [] -> zeroBitRepTy (a synonym) +-- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkTupleRepApp_maybe #-} +mkTupleRepApp_maybe (TyConApp tc args) + | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy -- ZeroBitRep + where + key = tyConUnique tc +mkTupleRepApp_maybe _ = Nothing + +{- Note [Using synonyms to compress types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Was: Prefer Type over TYPE (BoxedRep Lifted)] + +The Core of nearly any program will have numerous occurrences of the Types + + TyConApp BoxedRep [TyConApp Lifted []] -- Synonym LiftedRep + TyConApp BoxedRep [TyConApp Unlifted []] -- Synonym UnliftedREp + TyConApp TYPE [TyConApp LiftedRep []] -- Synonym Type + TyConApp TYPE [TyConApp UnliftedRep []] -- Synonym UnliftedType + +While investigating #17292 we found that these constituted a majority +of all TyConApp constructors on the heap: + + (From a sample of 100000 TyConApp closures) + 0x45f3523 - 28732 - `Type` + 0x420b840702 - 9629 - generic type constructors + 0x42055b7e46 - 9596 + 0x420559b582 - 9511 + 0x420bb15a1e - 9509 + 0x420b86c6ba - 9501 + 0x42055bac1e - 9496 + 0x45e68fd - 538 - `TYPE ...` Consequently, we try hard to ensure that operations on such types are efficient. Specifically, we strive to - a. Avoid heap allocation of such types + a. Avoid heap allocation of such types; use a single static TyConApp b. Use a small (shallow in the tree-depth sense) representation for such types @@ -1693,41 +1796,51 @@ Comparison in particular takes special advantage of nullary type synonym applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing nullary type synonyms] in "GHC.Core.Type". -To accomplish these we use a number of tricks: +To accomplish these we use a number of tricks, implemented by mkTyConApp. + + 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]), + we prefer a statically-allocated (TyConApp LiftedRep []) + where `LiftedRep` is a type synonym: + type LiftedRep = BoxedRep Lifted + Similarly for UnliftedRep - 1. Instead of representing the lifted kind as - @TyConApp tYPETyCon [liftedRepDataCon]@ we rather prefer to - use the 'GHC.Types.Type' type synonym (represented as a nullary TyConApp). - This serves goal (b) since there are no applied type arguments to traverse, - e.g., during comparison. + 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []]) + we prefer the statically-allocated (TyConApp Type []) + where `Type` is a type synonym + type Type = TYPE LiftedRep + Similarly for UnliftedType - 2. We have a top-level binding to represent `TyConApp GHC.Types.Type []` - (namely 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we - don't need to allocate such types (goal (a)). +These serve goal (b) since there are no applied type arguments to traverse, +e.g., during comparison. - 3. We use the sharing mechanism described in Note [Sharing nullary TyConApps] + 3. We have a single, statically allocated top-level binding to + represent `TyConApp GHC.Types.Type []` (namely + 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't + need to allocate such types (goal (a)). See functions + mkTYPEapp and mkBoxedRepApp + + 4. We use the sharing mechanism described in Note [Sharing nullary TyConApps] in GHC.Core.TyCon to ensure that we never need to allocate such nullary applications (goal (a)). -See #17958. --} +See #17958, #20541 +Note [Care using synonyms to compress types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Using a synonym to compress a types has a tricky wrinkle. Consider +coreView applied to (TyConApp LiftedRep []) + +* coreView expands the LiftedRep synonym: + type LiftedRep = BoxedRep Lifted + +* Danger: we might apply the empty substitution to the RHS of the + synonym. And substTy calls mkTyConApp BoxedRep [Lifted]. And + mkTyConApp compresses that back to LiftedRep. Loop! + +* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary + type synonyms. That's more efficient anyway. +-} --- | Given a @RuntimeRep@, applies @TYPE@ to it. --- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. -tYPE :: Type -> Type -tYPE rr@(TyConApp tc [arg]) - -- See Note [Prefer Type of TYPE 'LiftedRep] - | tc `hasKey` boxedRepDataConKey - , TyConApp tc' [] <- arg - = if | tc' `hasKey` liftedDataConKey -> liftedTypeKind -- TYPE (BoxedRep 'Lifted) - | tc' `hasKey` unliftedDataConKey -> unliftedTypeKind -- TYPE (BoxedRep 'Unlifted) - | otherwise -> TyConApp tYPETyCon [rr] - | tc == liftedRepTyCon -- TYPE LiftedRep - = liftedTypeKind - | tc == unliftedRepTyCon -- TYPE UnliftedRep - = unliftedTypeKind -tYPE rr = TyConApp tYPETyCon [rr] {- @@ -2528,8 +2641,8 @@ We perform this optimisation in a number of places: This optimisation is especially helpful for the ubiquitous GHC.Types.Type, since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications -whenever possible. See Note [Prefer Type over TYPE 'LiftedRep] in -GHC.Core.TyCo.Rep for details. +whenever possible. See Note [Using synonyms to compress types] in +GHC.Core.Type for details. -} diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot index e17cab9a40..94f9e34f83 100644 --- a/compiler/GHC/Core/Type.hs-boot +++ b/compiler/GHC/Core/Type.hs-boot @@ -22,7 +22,7 @@ isRuntimeRepTy :: Type -> Bool isLevityTy :: Type -> Bool isMultiplicityTy :: Type -> Bool isLiftedTypeKind :: Type -> Bool -tYPE :: Type -> Type +mkTYPEapp :: Type -> Type splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) tyConAppTyCon_maybe :: Type -> Maybe TyCon diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index bc87d42a75..d55bdf7115 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -740,7 +740,7 @@ mkUnsafeCoercePrimPair _old_id old_expr (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy runtimeRep1Ty runtimeRep2Ty - (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (tYPE runtimeRep2Ty) + (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty) (openAlphaTy `mkCastTy` alpha_co) openBetaTy diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 404008ac0e..ecca8a78e2 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -355,7 +355,7 @@ checkPostUnariseId id = is_sum, is_tuple, is_void :: Maybe String is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum" is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple" - is_void = guard (isVoidTy id_ty) >> return "void" + is_void = guard (isZeroBitTy id_ty) >> return "void" in is_sum <|> is_tuple <|> is_void diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index b3ae7957d9..15635e754a 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -557,7 +557,7 @@ mapTupleIdBinders -> UnariseEnv -> UnariseEnv mapTupleIdBinders ids args0 rho0 - = assert (not (any (isVoidTy . stgArgType) args0)) $ + = assert (not (any (isZeroBitTy . stgArgType) args0)) $ let ids_unarised :: [(Id, [PrimRep])] ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids @@ -591,7 +591,7 @@ mapSumIdBinders -> UnariseEnv mapSumIdBinders [id] args rho0 - = assert (not (any (isVoidTy . stgArgType) args)) $ + = assert (not (any (isZeroBitTy . stgArgType) args)) $ let arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args id_slots = map primRepSlot $ typePrimRep (idType id) @@ -777,15 +777,15 @@ unariseConArg rho (StgVarArg x) = Just (UnaryVal arg) -> [arg] Just (MultiVal as) -> as -- 'as' can be empty Nothing - | isVoidTy (idType x) -> [] -- e.g. C realWorld# - -- Here realWorld# is not in the envt, but - -- is a void, and so should be eliminated + | isZeroBitTy (idType x) -> [] -- e.g. C realWorld# + -- Here realWorld# is not in the envt, but + -- is a void, and so should be eliminated | otherwise -> [StgVarArg x] unariseConArg _ arg@(StgLitArg lit) | Just as <- unariseRubbish_maybe lit = as | otherwise - = assert (not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals + = assert (not (isZeroBitTy (literalType lit))) -- We have no non-rubbish void literals [arg] unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg] diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 3ff745a719..8b9e4f044b 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -151,23 +151,23 @@ instance (Outputable a) => Outputable (NonVoid a) where ppr (NonVoid a) = ppr a nonVoidIds :: [Id] -> [NonVoid Id] -nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))] +nonVoidIds ids = [NonVoid id | id <- ids, not (isZeroBitTy (idType id))] -- | Used in places where some invariant ensures that all these Ids are -- non-void; e.g. constructor field binders in case expressions. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidIds :: [Id] -> [NonVoid Id] -assertNonVoidIds ids = assert (not (any (isVoidTy . idType) ids)) $ +assertNonVoidIds ids = assert (not (any (isZeroBitTy . idType) ids)) $ coerce ids nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] -nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))] +nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isZeroBitTy (stgArgType arg))] -- | Used in places where some invariant ensures that all these arguments are -- non-void; e.g. constructor arguments. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] -assertNonVoidStgArgs args = assert (not (any (isVoidTy . stgArgType) args)) $ +assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $ coerce args diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 6355b55427..77476a4b7d 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -43,7 +43,7 @@ import GHC.Types.Id import GHC.Builtin.PrimOps import GHC.Core.TyCon import GHC.Core.Type ( isUnliftedType ) -import GHC.Types.RepType ( isVoidTy, countConRepArgs ) +import GHC.Types.RepType ( isZeroBitTy, countConRepArgs ) import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) import GHC.Types.Tickish import GHC.Data.Maybe @@ -896,12 +896,12 @@ cgIdApp fun_id args = do fun = idInfoToAmode fun_info lf_info = cg_lf fun_info n_args = length args - v_args = length $ filter (isVoidTy . stgArgType) args + v_args = length $ filter (isZeroBitTy . stgArgType) args case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of -- A value in WHNF, so we can just return it. ReturnIt - | isVoidTy (idType fun_id) -> emitReturn [] - | otherwise -> emitReturn [fun] + | isZeroBitTy (idType fun_id) -> emitReturn [] + | otherwise -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? EnterIt -> assert (null args) $ -- Discarding arguments diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index c62ec59e1c..3aba359f5b 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -761,7 +761,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn ; tv_name <- newNameAt (mkTyVarOcc "r") loc' ; let rr_tv = mkTyVar rr_name runtimeRepTy rr = mkTyVarTy rr_tv - res_tv = mkTyVar tv_name (tYPE rr) + res_tv = mkTyVar tv_name (mkTYPEapp rr) res_ty = mkTyVarTy res_tv is_unlifted = null args && null prov_dicts (cont_args, cont_arg_tys) diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index 56facd6970..9f279a9349 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -506,7 +506,7 @@ inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl -- See Note [inferResultToType] ; return ty } Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr) + ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) -- See Note [TcLevel of ExpType] ; writeMutVar ref (Just tau) ; return tau } @@ -683,7 +683,7 @@ promoteTcType dest_lvl ty promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty -- where alpha and rr are fresh and from level dest_lvl = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy - ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr) + ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr) ; let eq_orig = TypeEqOrigin { uo_actual = ty , uo_expected = prom_ty , uo_thing = Nothing @@ -1068,7 +1068,7 @@ newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) newOpenTypeKind :: TcM TcKind newOpenTypeKind = do { rr <- newFlexiTyVarTy runtimeRepTy - ; return (tYPE rr) } + ; return (mkTYPEapp rr) } -- | Create a tyvar that can be a lifted or unlifted type. -- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh @@ -1086,7 +1086,7 @@ newOpenBoxedTypeKind :: TcM TcKind newOpenBoxedTypeKind = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon) ; let rr = mkTyConApp boxedRepDataConTyCon [lev] - ; return (tYPE rr) } + ; return (mkTYPEapp rr) } newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Instantiate with META type variables diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 9955a025ea..01553cc1b5 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1593,19 +1593,19 @@ coerceId = pcMiscPrelId coerceName ty info info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs `setArityInfo` 2 - eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] - eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] + eqRTy = mkTyConApp coercibleTyCon [ tYPE_r, a, b ] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE_r, tYPE_r, a, b ] ty = mkInvisForAllTys [ Bndr rv InferredSpec , Bndr av SpecifiedSpec - , Bndr bv SpecifiedSpec - ] $ + , Bndr bv SpecifiedSpec ] $ mkInvisFunTyMany eqRTy $ mkVisFunTyMany a b bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy - (\r -> [tYPE r, tYPE r]) + (\r -> [mkTYPEapp r, mkTYPEapp r]) [r, a, b] = mkTyVarTys bndrs + tYPE_r = mkTYPEapp r [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] rhs = mkLams (bndrs ++ [eqR, x]) $ diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index 6240e3347a..5b14ecc78d 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -853,7 +853,7 @@ literalType (LitNumber lt _) = case lt of literalType (LitRubbish rep) = mkForAllTy a Inferred (mkTyVarTy a) where - a = mkTemplateKindVar (tYPE rep) + a = mkTemplateKindVar (mkTYPEapp rep) {- Comparison diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index a1ad6b8317..b2e8a1c3b8 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -8,7 +8,7 @@ module GHC.Types.RepType unwrapType, -- * Predicates on types - isVoidTy, + isZeroBitTy, -- * Type representation for the code generator typePrimRep, typePrimRep1, typeMonoPrimRep_maybe, @@ -128,8 +128,8 @@ countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) -- | True if the type has zero width. -isVoidTy :: Type -> Bool -isVoidTy = null . typePrimRep +isZeroBitTy :: Type -> Bool +isZeroBitTy = null . typePrimRep {- ********************************************************************** @@ -252,7 +252,7 @@ instance Outputable SlotTy where typeSlotTy :: UnaryType -> Maybe SlotTy typeSlotTy ty - | isVoidTy ty + | isZeroBitTy ty = Nothing | otherwise = Just (primRepSlot (typePrimRep1 ty)) @@ -565,4 +565,4 @@ runtimeRepPrimRep doc rr_ty -- to fresh Ids. Really, only the type's representation matters. -- See also Note [RuntimeRep and PrimRep] primRepToType :: PrimRep -> Type -primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep +primRepToType = anyTypeOfKind . mkTYPEapp . primRepToRuntimeRep diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 45f14e7691..d40e7a8f38 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -41,6 +41,7 @@ module GHC.Types ( -- The historical type * should ideally be written as -- `type *`, without the parentheses. But that's a true -- pain to parse, and for little gain. + ZeroBitRep, ZeroBitType, VecCount(..), VecElem(..), Void#, @@ -95,6 +96,11 @@ type LiftedRep = 'BoxedRep 'Lifted -- | The runtime representation of unlifted types. type UnliftedRep = 'BoxedRep 'Unlifted +-- | The runtime representation of a zero-width tuple, +-- represented by no bits at all +type ZeroBitRep = 'TupleRep '[] + +------------------------- -- | The kind of types with lifted values. For example @Int :: Type@. type Type = TYPE LiftedRep @@ -102,6 +108,10 @@ type Type = TYPE LiftedRep -- unlifted data type, using @-XUnliftedDataTypes@. type UnliftedType = TYPE UnliftedRep +-- | The kind of the empty unboxed tuple type (# #) +type ZeroBitType = TYPE ZeroBitRep + +------------------------- data Multiplicity = Many | One type family MultMul (a :: Multiplicity) (b :: Multiplicity) :: Multiplicity where diff --git a/testsuite/tests/dependent/should_fail/T17131.stderr b/testsuite/tests/dependent/should_fail/T17131.stderr index b2af8ab7b8..3ab5c50665 100644 --- a/testsuite/tests/dependent/should_fail/T17131.stderr +++ b/testsuite/tests/dependent/should_fail/T17131.stderr @@ -1,9 +1,9 @@ T17131.hs:12:34: error: • Couldn't match kind: TypeReps xs - with: '[ 'BoxedRep 'Lifted] + with: '[LiftedRep] Expected kind ‘TYPE ('TupleRep (TypeReps xs))’, - but ‘(# a #)’ has kind ‘TYPE ('TupleRep '[ 'BoxedRep 'Lifted])’ + but ‘(# a #)’ has kind ‘TYPE ('TupleRep '[LiftedRep])’ The type variable ‘xs’ is ambiguous • In the type ‘(# a #)’ In the type family declaration for ‘Tuple#’ diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index 2a2b8bd58f..0bc51c87b5 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -9,7 +9,7 @@ instance Enum () -- Defined in ‘GHC.Enum’ instance Show () -- Defined in ‘GHC.Show’ instance Read () -- Defined in ‘GHC.Read’ instance Bounded () -- Defined in ‘GHC.Enum’ -type (##) :: TYPE ('GHC.Types.TupleRep '[]) +type (##) :: GHC.Types.ZeroBitType data (##) = (##) -- Defined in ‘GHC.Prim’ () :: () diff --git a/testsuite/tests/plugins/plugins09.stdout b/testsuite/tests/plugins/plugins09.stdout index f32fbe4a09..b68572dd7a 100644 --- a/testsuite/tests/plugins/plugins09.stdout +++ b/testsuite/tests/plugins/plugins09.stdout @@ -4,6 +4,5 @@ interfacePlugin: GHC.Base interfacePlugin: GHC.Float interfacePlugin: GHC.Prim.Ext typeCheckPlugin (rn) -interfacePlugin: GHC.Prim typeCheckPlugin (tc) interfacePlugin: GHC.Num.BigNat diff --git a/testsuite/tests/plugins/plugins10.stdout b/testsuite/tests/plugins/plugins10.stdout index f9aa7f19b6..7f565937cf 100644 --- a/testsuite/tests/plugins/plugins10.stdout +++ b/testsuite/tests/plugins/plugins10.stdout @@ -7,7 +7,6 @@ interfacePlugin: GHC.Float interfacePlugin: GHC.Prim.Ext interfacePlugin: Language.Haskell.TH.Syntax typeCheckPlugin (rn) -interfacePlugin: GHC.Prim typeCheckPlugin (tc) interfacePlugin: GHC.Num.BigNat parsePlugin(a) diff --git a/testsuite/tests/plugins/plugins11.stdout b/testsuite/tests/plugins/plugins11.stdout index 0a9c0dcb88..cac32c0701 100644 --- a/testsuite/tests/plugins/plugins11.stdout +++ b/testsuite/tests/plugins/plugins11.stdout @@ -4,6 +4,5 @@ interfacePlugin: GHC.Base interfacePlugin: GHC.Float interfacePlugin: GHC.Prim.Ext typeCheckPlugin (rn) -interfacePlugin: GHC.Prim typeCheckPlugin (tc) interfacePlugin: GHC.Num.BigNat diff --git a/testsuite/tests/plugins/static-plugins.stdout b/testsuite/tests/plugins/static-plugins.stdout index 3f7387fc4c..5da8e9bee8 100644 --- a/testsuite/tests/plugins/static-plugins.stdout +++ b/testsuite/tests/plugins/static-plugins.stdout @@ -6,12 +6,12 @@ interfacePlugin: GHC.Float interfacePlugin: GHC.Prim.Ext interfacePlugin: System.IO typeCheckPlugin (rn) -interfacePlugin: GHC.Prim interfacePlugin: GHC.Types interfacePlugin: GHC.Show interfacePlugin: GHC.TopHandler typeCheckPlugin (tc) interfacePlugin: GHC.CString +interfacePlugin: GHC.Prim interfacePlugin: GHC.Num.BigNat ==pure.1 ==fp0.0 diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr index 134078e7e8..fe48290c49 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.stderr +++ b/testsuite/tests/simplCore/should_compile/T18013.stderr @@ -131,9 +131,9 @@ Rule fired: Class op fmap (BUILTIN) ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 52, types: 102, coercions: 17, joins: 0/1} + = {terms: 52, types: 95, coercions: 17, joins: 0/1} --- RHS size: {terms: 37, types: 85, coercions: 17, joins: 0/1} +-- RHS size: {terms: 37, types: 78, coercions: 17, joins: 0/1} mapMaybeRule [InlPrag=[2]] :: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b) [GblId, diff --git a/testsuite/tests/typecheck/should_fail/T15883b.stderr b/testsuite/tests/typecheck/should_fail/T15883b.stderr index 81c6da1b69..4da31915ac 100644 --- a/testsuite/tests/typecheck/should_fail/T15883b.stderr +++ b/testsuite/tests/typecheck/should_fail/T15883b.stderr @@ -6,13 +6,13 @@ T15883b.hs:14:1: error: These potential instances exist: instance Eq SpecConstrAnnotation -- Defined in ‘GHC.Exts’ instance Eq Ordering -- Defined in ‘GHC.Classes’ - instance Eq (Foo ('BoxedRep 'Lifted)) -- Defined at T15883b.hs:14:1 + instance Eq (Foo LiftedRep) -- Defined at T15883b.hs:14:1 ...plus 24 others ...plus four instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In the expression: a1 == b1 In an equation for ‘==’: (==) (MkFoo a1) (MkFoo b1) = ((a1 == b1)) When typechecking the code for ‘==’ - in a derived instance for ‘Eq (Foo ('BoxedRep 'Lifted))’: + in a derived instance for ‘Eq (Foo LiftedRep)’: To see the code I am typechecking, use -ddump-deriv - In the instance declaration for ‘Eq (Foo ('BoxedRep 'Lifted))’ + In the instance declaration for ‘Eq (Foo LiftedRep)’ diff --git a/testsuite/tests/typecheck/should_fail/T15883c.stderr b/testsuite/tests/typecheck/should_fail/T15883c.stderr index 4ef9e5ef52..07451af880 100644 --- a/testsuite/tests/typecheck/should_fail/T15883c.stderr +++ b/testsuite/tests/typecheck/should_fail/T15883c.stderr @@ -1,8 +1,8 @@ T15883c.hs:14:1: error: - • No instance for (Eq (Foo ('BoxedRep 'Lifted))) + • No instance for (Eq (Foo LiftedRep)) arising from the superclasses of an instance declaration - • In the instance declaration for ‘Ord (Foo ('BoxedRep 'Lifted))’ + • In the instance declaration for ‘Ord (Foo LiftedRep)’ T15883c.hs:14:1: error: • Ambiguous type variable ‘a0’ arising from a use of ‘compare’ @@ -10,8 +10,7 @@ T15883c.hs:14:1: error: Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: instance Ord Ordering -- Defined in ‘GHC.Classes’ - instance Ord (Foo ('BoxedRep 'Lifted)) - -- Defined at T15883c.hs:14:1 + instance Ord (Foo LiftedRep) -- Defined at T15883c.hs:14:1 instance Ord Integer -- Defined in ‘GHC.Num.Integer’ ...plus 23 others ...plus two instances involving out-of-scope types @@ -20,7 +19,7 @@ T15883c.hs:14:1: error: In a case alternative: MkFoo b1 -> (a1 `compare` b1) In the expression: case b of MkFoo b1 -> (a1 `compare` b1) When typechecking the code for ‘compare’ - in a derived instance for ‘Ord (Foo ('BoxedRep 'Lifted))’: + in a derived instance for ‘Ord (Foo LiftedRep)’: To see the code I am typechecking, use -ddump-deriv T15883c.hs:14:1: error: @@ -29,8 +28,7 @@ T15883c.hs:14:1: error: Probable fix: use a type annotation to specify what ‘a1’ should be. These potential instances exist: instance Ord Ordering -- Defined in ‘GHC.Classes’ - instance Ord (Foo ('BoxedRep 'Lifted)) - -- Defined at T15883c.hs:14:1 + instance Ord (Foo LiftedRep) -- Defined at T15883c.hs:14:1 instance Ord Integer -- Defined in ‘GHC.Num.Integer’ ...plus 23 others ...plus two instances involving out-of-scope types @@ -39,5 +37,5 @@ T15883c.hs:14:1: error: In a case alternative: MkFoo b1 -> (a1 < b1) In the expression: case b of MkFoo b1 -> (a1 < b1) When typechecking the code for ‘<’ - in a derived instance for ‘Ord (Foo ('BoxedRep 'Lifted))’: + in a derived instance for ‘Ord (Foo LiftedRep)’: To see the code I am typechecking, use -ddump-deriv diff --git a/testsuite/tests/typecheck/should_fail/T15883d.stderr b/testsuite/tests/typecheck/should_fail/T15883d.stderr index 67ce3eff57..ba5618628d 100644 --- a/testsuite/tests/typecheck/should_fail/T15883d.stderr +++ b/testsuite/tests/typecheck/should_fail/T15883d.stderr @@ -5,8 +5,7 @@ T15883d.hs:14:1: error: Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: instance Show Ordering -- Defined in ‘GHC.Show’ - instance Show (Foo ('BoxedRep 'Lifted)) - -- Defined at T15883d.hs:14:1 + instance Show (Foo LiftedRep) -- Defined at T15883d.hs:14:1 instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ ...plus 28 others ...plus 9 instances involving out-of-scope types @@ -17,5 +16,5 @@ T15883d.hs:14:1: error: In the expression: showParen (a >= 11) ((.) (showString "MkFoo ") (showsPrec 11 b1)) When typechecking the code for ‘showsPrec’ - in a derived instance for ‘Show (Foo ('BoxedRep 'Lifted))’: + in a derived instance for ‘Show (Foo LiftedRep)’: To see the code I am typechecking, use -ddump-deriv diff --git a/testsuite/tests/typecheck/should_fail/T15883e.stderr b/testsuite/tests/typecheck/should_fail/T15883e.stderr index 72483274e9..81b6d8172a 100644 --- a/testsuite/tests/typecheck/should_fail/T15883e.stderr +++ b/testsuite/tests/typecheck/should_fail/T15883e.stderr @@ -15,9 +15,9 @@ T15883e.hs:16:1: error: In an equation for ‘Data.Data.gfoldl’: Data.Data.gfoldl k z (MkFoo a1) = (z (\ a1 -> MkFoo a1) `k` a1) When typechecking the code for ‘Data.Data.gfoldl’ - in a derived instance for ‘Data (Foo ('BoxedRep 'Lifted))’: + in a derived instance for ‘Data (Foo LiftedRep)’: To see the code I am typechecking, use -ddump-deriv - In the instance declaration for ‘Data (Foo ('BoxedRep 'Lifted))’ + In the instance declaration for ‘Data (Foo LiftedRep)’ T15883e.hs:16:1: error: • Couldn't match expected type ‘a’ with actual type ‘d0’ @@ -30,7 +30,7 @@ T15883e.hs:16:1: error: In the expression: MkFoo a1 In the first argument of ‘z’, namely ‘(\ a1 -> MkFoo a1)’ When typechecking the code for ‘Data.Data.gfoldl’ - in a derived instance for ‘Data (Foo ('BoxedRep 'Lifted))’: + in a derived instance for ‘Data (Foo LiftedRep)’: To see the code I am typechecking, use -ddump-deriv • Relevant bindings include a1 :: d0 (bound at T15883e.hs:16:1) @@ -50,9 +50,9 @@ T15883e.hs:16:1: error: In an equation for ‘Data.Data.gunfold’: Data.Data.gunfold k z _ = k (z (\ a1 -> MkFoo a1)) When typechecking the code for ‘Data.Data.gunfold’ - in a derived instance for ‘Data (Foo ('BoxedRep 'Lifted))’: + in a derived instance for ‘Data (Foo LiftedRep)’: To see the code I am typechecking, use -ddump-deriv - In the instance declaration for ‘Data (Foo ('BoxedRep 'Lifted))’ + In the instance declaration for ‘Data (Foo LiftedRep)’ T15883e.hs:16:1: error: • Couldn't match expected type ‘a’ with actual type ‘b0’ @@ -65,6 +65,6 @@ T15883e.hs:16:1: error: In the expression: MkFoo a1 In the first argument of ‘z’, namely ‘(\ a1 -> MkFoo a1)’ When typechecking the code for ‘Data.Data.gunfold’ - in a derived instance for ‘Data (Foo ('BoxedRep 'Lifted))’: + in a derived instance for ‘Data (Foo LiftedRep)’: To see the code I am typechecking, use -ddump-deriv • Relevant bindings include a1 :: b0 (bound at T15883e.hs:16:1) diff --git a/testsuite/tests/typecheck/should_run/KindInvariant.stderr b/testsuite/tests/typecheck/should_run/KindInvariant.stderr index 9d404ae088..fb4dd69779 100644 --- a/testsuite/tests/typecheck/should_run/KindInvariant.stderr +++ b/testsuite/tests/typecheck/should_run/KindInvariant.stderr @@ -2,6 +2,6 @@ <interactive>:1:3: error: • Couldn't match a lifted type with an unlifted type Expected kind ‘* -> *’, - but ‘State#’ has kind ‘* -> TYPE ('TupleRep '[])’ + but ‘State#’ has kind ‘* -> GHC.Types.ZeroBitType’ • In the first argument of ‘T’, namely ‘State#’ In the type ‘T State#’ diff --git a/testsuite/tests/unboxedsums/T12711.stdout b/testsuite/tests/unboxedsums/T12711.stdout index 18a67a078d..2db54da01b 100644 --- a/testsuite/tests/unboxedsums/T12711.stdout +++ b/testsuite/tests/unboxedsums/T12711.stdout @@ -1,4 +1,2 @@ (# _ | _ #) :: TYPE - ('GHC.Types.SumRep - '[ 'GHC.Types.BoxedRep 'GHC.Types.Lifted, - 'GHC.Types.BoxedRep 'GHC.Types.Lifted]) + ('GHC.Types.SumRep '[GHC.Types.LiftedRep, GHC.Types.LiftedRep]) |