From 3e082f8ff5ea2f42c5e6430094683b26b5818fb8 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Tue, 2 Feb 2021 10:06:11 -0500 Subject: Implement BoxedRep proposal This implements the BoxedRep proposal, refactoring the `RuntimeRep` hierarchy from: ```haskell data RuntimeRep = LiftedPtrRep | UnliftedPtrRep | ... ``` to ```haskell data RuntimeRep = BoxedRep Levity | ... data Levity = Lifted | Unlifted ``` Updates binary, haddock submodules. Closes #17526. Metric Increase: T12545 --- libraries/base/Data/Typeable.hs | 2 + libraries/base/Data/Typeable/Internal.hs | 66 ++++++++++++++++++---- libraries/base/GHC/Enum.hs | 5 ++ libraries/base/GHC/Exts.hs | 3 +- libraries/base/GHC/Show.hs | 3 + libraries/base/Unsafe/Coerce.hs | 2 +- libraries/base/tests/T11334a.hs | 4 +- libraries/base/tests/T11334a.stdout | 2 +- libraries/binary | 2 +- libraries/ghc-heap/GHC/Exts/Heap.hs | 8 +++ libraries/ghc-heap/tests/ClosureSizeUtils.hs | 2 +- libraries/ghc-prim/GHC/Types.hs | 21 +++++-- .../template-haskell/Language/Haskell/TH/Syntax.hs | 8 +++ 13 files changed, 107 insertions(+), 21 deletions(-) (limited to 'libraries') diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs index 43c9aa187d..1c84c99021 100644 --- a/libraries/base/Data/Typeable.hs +++ b/libraries/base/Data/Typeable.hs @@ -89,6 +89,8 @@ module Data.Typeable -- * For backwards compatibility , typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7 + -- Jank + , I.trLiftedRep ) where import qualified Data.Typeable.Internal as I diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 008ac1b81b..39974b4052 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ViewPatterns #-} @@ -79,7 +80,10 @@ module Data.Typeable.Internal ( -- | These are for internal use only mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun, mkTyCon, mkTyCon#, - typeSymbolTypeRep, typeNatTypeRep, typeCharTypeRep + typeSymbolTypeRep, typeNatTypeRep, typeCharTypeRep, + + -- * For internal use + trLiftedRep ) where import GHC.Prim ( FUN ) @@ -375,7 +379,12 @@ mkTrCon tc kind_vars = TrTyCon -- constructor, so we need to build it here. fpTYPELiftedRep :: Fingerprint fpTYPELiftedRep = fingerprintFingerprints - [tyConFingerprint tyConTYPE, typeRepFingerprint trLiftedRep] + [ tyConFingerprint tyConTYPE + , fingerprintFingerprints + [ tyConFingerprint tyCon'BoxedRep + , tyConFingerprint tyCon'Lifted + ] + ] -- There is absolutely nothing to gain and everything to lose -- by inlining the worker. The wrapper should inline anyway. {-# NOINLINE fpTYPELiftedRep #-} @@ -383,7 +392,7 @@ fpTYPELiftedRep = fingerprintFingerprints trTYPE :: TypeRep TYPE trTYPE = typeRep -trLiftedRep :: TypeRep 'LiftedRep +trLiftedRep :: TypeRep ('BoxedRep 'Lifted) trLiftedRep = typeRep trMany :: TypeRep 'Many @@ -623,7 +632,7 @@ instantiateKindRep vars = go = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a) go (KindRepFun a b) = SomeTypeRep $ mkTrFun trMany (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b) - go (KindRepTYPE LiftedRep) = SomeTypeRep TrType + go (KindRepTYPE (BoxedRep Lifted)) = SomeTypeRep TrType go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r go (KindRepTypeLitS sort s) = mkTypeLitFromString sort (unpackCStringUtf8# s) @@ -662,8 +671,9 @@ buildList = foldr cons nil runtimeRepTypeRep :: RuntimeRep -> SomeKindedTypeRep RuntimeRep runtimeRepTypeRep r = case r of - LiftedRep -> rep @'LiftedRep - UnliftedRep -> rep @'UnliftedRep + BoxedRep Lifted -> SomeKindedTypeRep trLiftedRep + BoxedRep v -> kindedTypeRep @_ @'BoxedRep + `kApp` levityTypeRep v VecRep c e -> kindedTypeRep @_ @'VecRep `kApp` vecCountTypeRep c `kApp` vecElemTypeRep e @@ -688,6 +698,15 @@ runtimeRepTypeRep r = rep :: forall (a :: RuntimeRep). Typeable a => SomeKindedTypeRep RuntimeRep rep = kindedTypeRep @RuntimeRep @a +levityTypeRep :: Levity -> SomeKindedTypeRep Levity +levityTypeRep c = + case c of + Lifted -> rep @'Lifted + Unlifted -> rep @'Unlifted + where + rep :: forall (a :: Levity). Typeable a => SomeKindedTypeRep Levity + rep = kindedTypeRep @Levity @a + vecCountTypeRep :: VecCount -> SomeKindedTypeRep VecCount vecCountTypeRep c = case c of @@ -840,13 +859,40 @@ splitApps = go [] -- produce a TypeRep for without difficulty), and then just substitute in the -- appropriate module and constructor names. -- +-- Prior to the introduction of BoxedRep, this was bad, but now it is +-- even worse! We have to construct several different TyCons by hand +-- so that we can build the fingerprint for TYPE ('BoxedRep 'LiftedRep). +-- If we call `typeRep @('BoxedRep 'LiftedRep)` while trying to compute +-- the fingerprint of `TYPE ('BoxedRep 'LiftedRep)`, we get a loop. +-- -- The ticket to find a better way to deal with this is -- #14480. + +tyConRuntimeRep :: TyCon +tyConRuntimeRep = mkTyCon ghcPrimPackage "GHC.Types" "RuntimeRep" 0 + (KindRepTYPE (BoxedRep Lifted)) + tyConTYPE :: TyCon -tyConTYPE = mkTyCon (tyConPackage liftedRepTyCon) "GHC.Prim" "TYPE" 0 - (KindRepFun (KindRepTyConApp liftedRepTyCon []) (KindRepTYPE LiftedRep)) - where - liftedRepTyCon = typeRepTyCon (typeRep @RuntimeRep) +tyConTYPE = mkTyCon ghcPrimPackage "GHC.Prim" "TYPE" 0 + (KindRepFun + (KindRepTyConApp tyConRuntimeRep []) + (KindRepTYPE (BoxedRep Lifted)) + ) + +tyConLevity :: TyCon +tyConLevity = mkTyCon ghcPrimPackage "GHC.Types" "Levity" 0 + (KindRepTYPE (BoxedRep Lifted)) + +tyCon'Lifted :: TyCon +tyCon'Lifted = mkTyCon ghcPrimPackage "GHC.Types" "'Lifted" 0 + (KindRepTyConApp tyConLevity []) + +tyCon'BoxedRep :: TyCon +tyCon'BoxedRep = mkTyCon ghcPrimPackage "GHC.Types" "'BoxedRep" 0 + (KindRepFun (KindRepTyConApp tyConLevity []) (KindRepTyConApp tyConRuntimeRep [])) + +ghcPrimPackage :: String +ghcPrimPackage = tyConPackage (typeRepTyCon (typeRep @Bool)) funTyCon :: TyCon funTyCon = typeRepTyCon (typeRep @(->)) diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs index d107c1eb12..02b3d0e784 100644 --- a/libraries/base/GHC/Enum.hs +++ b/libraries/base/GHC/Enum.hs @@ -1005,6 +1005,11 @@ enumNegDeltaToNatural x0 ndelta lim = go x0 -- Instances from GHC.Types +-- | @since 4.16.0.0 +deriving instance Bounded Levity +-- | @since 4.16.0.0 +deriving instance Enum Levity + -- | @since 4.10.0.0 deriving instance Bounded VecCount -- | @since 4.10.0.0 diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index 106c7e9ea6..4b88d34c63 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -90,7 +90,8 @@ module GHC.Exts type (~~), -- * Representation polymorphism - GHC.Prim.TYPE, RuntimeRep(..), VecCount(..), VecElem(..), + GHC.Prim.TYPE, RuntimeRep(..), LiftedRep, Levity(..), + VecCount(..), VecElem(..), -- * Transform comprehensions Down(..), groupWith, sortWith, the, diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs index 97d6ad31c7..0d90006432 100644 --- a/libraries/base/GHC/Show.hs +++ b/libraries/base/GHC/Show.hs @@ -598,6 +598,9 @@ instance Show KindRep where . showString " " . showsPrec 11 q +-- | @since 4.15.0.0 +deriving instance Show Levity + -- | @since 4.11.0.0 deriving instance Show RuntimeRep diff --git a/libraries/base/Unsafe/Coerce.hs b/libraries/base/Unsafe/Coerce.hs index 7c8e39e92e..1341a4d1d7 100644 --- a/libraries/base/Unsafe/Coerce.hs +++ b/libraries/base/Unsafe/Coerce.hs @@ -285,7 +285,7 @@ unsafeEqualityProof = case unsafeEqualityProof @a @b of UnsafeRefl -> UnsafeRefl unsafeCoerce :: forall (a :: Type) (b :: Type) . a -> b unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x -unsafeCoerceUnlifted :: forall (a :: TYPE 'UnliftedRep) (b :: TYPE 'UnliftedRep) . a -> b +unsafeCoerceUnlifted :: forall (a :: TYPE ('BoxedRep 'Unlifted)) (b :: TYPE ('BoxedRep 'Unlifted)) . a -> b -- Kind-homogeneous, but levity monomorphic (TYPE UnliftedRep) unsafeCoerceUnlifted x = case unsafeEqualityProof @a @b of UnsafeRefl -> x diff --git a/libraries/base/tests/T11334a.hs b/libraries/base/tests/T11334a.hs index 0cf91eaa2a..ad296967a7 100644 --- a/libraries/base/tests/T11334a.hs +++ b/libraries/base/tests/T11334a.hs @@ -7,5 +7,5 @@ import GHC.Types main :: IO () main = do print (typeOf (Proxy :: Proxy 'Just)) - print (typeOf (Proxy :: Proxy (TYPE 'LiftedRep))) - print (typeOf (Proxy :: Proxy (TYPE 'UnliftedRep))) + print (typeOf (Proxy :: Proxy (TYPE ('BoxedRep 'Lifted)))) + print (typeOf (Proxy :: Proxy (TYPE ('BoxedRep 'Unlifted)))) diff --git a/libraries/base/tests/T11334a.stdout b/libraries/base/tests/T11334a.stdout index c2d860d653..b46a92d366 100644 --- a/libraries/base/tests/T11334a.stdout +++ b/libraries/base/tests/T11334a.stdout @@ -1,3 +1,3 @@ Proxy (* -> Maybe *) ('Just *) Proxy * * -Proxy * (TYPE 'UnliftedRep) +Proxy * (TYPE ('BoxedRep 'Unlifted)) diff --git a/libraries/binary b/libraries/binary index d0c3f06716..6d3cb9fdc9 160000 --- a/libraries/binary +++ b/libraries/binary @@ -1 +1 @@ -Subproject commit d0c3f06716be373e4195535a76f94f1bba8ab974 +Subproject commit 6d3cb9fdc961cc6cce23860d74316c635ed90945 diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs index 10a9ea8be9..1e429ca054 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap.hs @@ -91,10 +91,18 @@ class HasHeapRep (a :: TYPE rep) where -> IO Closure -- ^ Heap representation of the closure. +#if __GLASGOW_HASKELL__ >= 901 +instance HasHeapRep (a :: TYPE ('BoxedRep 'Lifted)) where +#else instance HasHeapRep (a :: TYPE 'LiftedRep) where +#endif getClosureData = getClosureDataFromHeapObject +#if __GLASGOW_HASKELL__ >= 901 +instance HasHeapRep (a :: TYPE ('BoxedRep 'Unlifted)) where +#else instance HasHeapRep (a :: TYPE 'UnliftedRep) where +#endif getClosureData x = getClosureDataFromHeapObject (unsafeCoerce# x) instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where diff --git a/libraries/ghc-heap/tests/ClosureSizeUtils.hs b/libraries/ghc-heap/tests/ClosureSizeUtils.hs index 5fafa4f7a5..3b1578451a 100644 --- a/libraries/ghc-heap/tests/ClosureSizeUtils.hs +++ b/libraries/ghc-heap/tests/ClosureSizeUtils.hs @@ -30,7 +30,7 @@ assertSize x = assertSizeBox (asBox x) (typeRep @a) assertSizeUnlifted - :: forall (a :: TYPE 'UnliftedRep). (HasCallStack, Typeable a) + :: forall (a :: TYPE ('BoxedRep 'Unlifted)). (HasCallStack, Typeable a) => a -- ^ closure -> Int -- ^ expected size in words -> IO () diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index f558619ac1..59edeec8af 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -33,7 +33,9 @@ module GHC.Types ( Symbol, Any, type (~~), Coercible, - TYPE, RuntimeRep(..), Type, Constraint, + TYPE, Levity(..), RuntimeRep(..), + LiftedRep, UnliftedRep, + Type, UnliftedType, Constraint, -- The historical type * should ideally be written as -- `type *`, without the parentheses. But that's a true -- pain to parse, and for little gain. @@ -85,8 +87,17 @@ type (->) = FUN 'Many -- | The kind of constraints, like @Show a@ data Constraint +-- | The runtime representation of lifted types. +type LiftedRep = 'BoxedRep 'Lifted + +-- | The runtime representation of unlifted types. +type UnliftedRep = 'BoxedRep 'Unlifted + -- | The kind of types with lifted values. For example @Int :: Type@. -type Type = TYPE 'LiftedRep +type Type = TYPE LiftedRep + +-- | The kind of types with unlifted values. For example @Int# :: UnliftedType@. +type UnliftedType = TYPE UnliftedRep data Multiplicity = Many | One @@ -410,6 +421,8 @@ data SPEC = SPEC | SPEC2 * * ********************************************************************* -} +-- | Whether a boxed type is lifted or unlifted. +data Levity = Lifted | Unlifted -- | GHC maintains a property that the kind of all inhabited types -- (as distinct from type constructors or type-level data) tells us @@ -425,8 +438,7 @@ data SPEC = SPEC | SPEC2 data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type | TupleRep [RuntimeRep] -- ^ An unboxed tuple of the given reps | SumRep [RuntimeRep] -- ^ An unboxed sum of the given reps - | LiftedRep -- ^ lifted; represented by a pointer - | UnliftedRep -- ^ unlifted; represented by a pointer + | BoxedRep Levity -- ^ boxed; represented by a pointer | IntRep -- ^ signed, word-sized value | Int8Rep -- ^ signed, 8-bit value | Int16Rep -- ^ signed, 16-bit value @@ -444,6 +456,7 @@ data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type -- RuntimeRep is intimately tied to TyCon.RuntimeRep (in GHC proper). See -- Note [RuntimeRep and PrimRep] in RepType. -- See also Note [Wiring in RuntimeRep] in GHC.Builtin.Types +-- See also Note [TYPE and RuntimeRep] in GHC.Builtin.Type.Prim -- | Length of a SIMD vector type data VecCount = Vec2 diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 6508c07a65..3cb5a44ee8 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -61,6 +61,10 @@ import Foreign.ForeignPtr import Foreign.C.String import Foreign.C.Types +#if __GLASGOW_HASKELL__ >= 901 +import GHC.Types ( Levity(..) ) +#endif + ----------------------------------------------------- -- -- The Quasi class @@ -816,7 +820,11 @@ class Lift (t :: TYPE r) where -- | Turn a value into a Template Haskell expression, suitable for use in -- a splice. lift :: Quote m => t -> m Exp +#if __GLASGOW_HASKELL__ >= 901 + default lift :: (r ~ ('BoxedRep 'Lifted), Quote m) => t -> m Exp +#else default lift :: (r ~ 'LiftedRep, Quote m) => t -> m Exp +#endif lift = unTypeCode . liftTyped -- | Turn a value into a Template Haskell typed expression, suitable for use -- cgit v1.2.1