diff options
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]) |