diff options
| author | Andrew Martin <andrew.thaddeus@gmail.com> | 2020-10-07 15:45:30 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-12-14 18:48:51 -0500 |
| commit | 6c2eb2232b39ff4720fda0a4a009fb6afbc9dcea (patch) | |
| tree | 0a19d6cece0d63aadcfa6e014171a5baeaf4c167 | |
| parent | dad87210efffce9cfc2d17dc088a71d9dea14535 (diff) | |
| download | haskell-6c2eb2232b39ff4720fda0a4a009fb6afbc9dcea.tar.gz | |
Implement BoxedRep proposal
This implements the BoxedRep proposal, refacoring the `RuntimeRep`
hierarchy from:
```haskell
data RuntimeRep = LiftedPtrRep | UnliftedPtrRep | ...
```
to
```haskell
data RuntimeRep = BoxedRep Levity | ...
data Levity = Lifted | Unlifted
```
Closes #17526.
95 files changed, 632 insertions, 263 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index cf0f72c50f..caa577a877 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -1767,7 +1767,7 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, - liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, + anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, eqReprPrimTyConKey, eqPhantPrimTyConKey, @@ -1790,8 +1790,6 @@ word32PrimTyConKey = mkPreludeTyConUnique 65 word32TyConKey = mkPreludeTyConUnique 66 word64PrimTyConKey = mkPreludeTyConUnique 67 word64TyConKey = mkPreludeTyConUnique 68 -liftedConKey = mkPreludeTyConUnique 69 -unliftedConKey = mkPreludeTyConUnique 70 anyBoxConKey = mkPreludeTyConUnique 71 kindConKey = mkPreludeTyConUnique 72 boxityConKey = mkPreludeTyConUnique 73 @@ -1807,15 +1805,17 @@ eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84 -- Kind constructors -liftedTypeKindTyConKey, tYPETyConKey, - constraintKindTyConKey, runtimeRepTyConKey, +liftedTypeKindTyConKey, tYPETyConKey, liftedRepTyConKey, + constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey, vecCountTyConKey, vecElemTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 87 tYPETyConKey = mkPreludeTyConUnique 88 constraintKindTyConKey = mkPreludeTyConUnique 92 +levityTyConKey = mkPreludeTyConUnique 94 runtimeRepTyConKey = mkPreludeTyConUnique 95 vecCountTyConKey = mkPreludeTyConUnique 96 vecElemTyConKey = mkPreludeTyConUnique 97 +liftedRepTyConKey = mkPreludeTyConUnique 98 pluginTyConKey, frontendPluginTyConKey :: Unique pluginTyConKey = mkPreludeTyConUnique 102 @@ -2073,58 +2073,60 @@ metaDataDataConKey = mkPreludeDataConUnique 68 metaConsDataConKey = mkPreludeDataConUnique 69 metaSelDataConKey = mkPreludeDataConUnique 70 -vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique +vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey, + boxedRepDataConKey :: Unique vecRepDataConKey = mkPreludeDataConUnique 71 tupleRepDataConKey = mkPreludeDataConUnique 72 sumRepDataConKey = mkPreludeDataConUnique 73 +boxedRepDataConKey = mkPreludeDataConUnique 74 -- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types -runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique] -liftedRepDataConKey :: Unique -runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys) - = map mkPreludeDataConUnique [74..88] +-- Includes all nullary-data-constructor reps. Does not +-- include BoxedRep, VecRep, SumRep, TupleRep. +runtimeRepSimpleDataConKeys :: [Unique] +runtimeRepSimpleDataConKeys + = map mkPreludeDataConUnique [75..87] -unliftedRepDataConKeys = vecRepDataConKey : - tupleRepDataConKey : - sumRepDataConKey : - unliftedSimpleRepDataConKeys +liftedDataConKey,unliftedDataConKey :: Unique +liftedDataConKey = mkPreludeDataConUnique 88 +unliftedDataConKey = mkPreludeDataConUnique 89 -- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types -- VecCount vecCountDataConKeys :: [Unique] -vecCountDataConKeys = map mkPreludeDataConUnique [89..94] +vecCountDataConKeys = map mkPreludeDataConUnique [90..95] -- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types -- VecElem vecElemDataConKeys :: [Unique] -vecElemDataConKeys = map mkPreludeDataConUnique [95..104] +vecElemDataConKeys = map mkPreludeDataConUnique [96..105] -- Typeable things kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, kindRepFunDataConKey, kindRepTYPEDataConKey, kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey :: Unique -kindRepTyConAppDataConKey = mkPreludeDataConUnique 105 -kindRepVarDataConKey = mkPreludeDataConUnique 106 -kindRepAppDataConKey = mkPreludeDataConUnique 107 -kindRepFunDataConKey = mkPreludeDataConUnique 108 -kindRepTYPEDataConKey = mkPreludeDataConUnique 109 -kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110 -kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111 +kindRepTyConAppDataConKey = mkPreludeDataConUnique 106 +kindRepVarDataConKey = mkPreludeDataConUnique 107 +kindRepAppDataConKey = mkPreludeDataConUnique 108 +kindRepFunDataConKey = mkPreludeDataConUnique 109 +kindRepTYPEDataConKey = mkPreludeDataConUnique 110 +kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111 +kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112 typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique -typeLitSymbolDataConKey = mkPreludeDataConUnique 112 -typeLitNatDataConKey = mkPreludeDataConUnique 113 +typeLitSymbolDataConKey = mkPreludeDataConUnique 113 +typeLitNatDataConKey = mkPreludeDataConUnique 114 -- Unsafe equality unsafeReflDataConKey :: Unique -unsafeReflDataConKey = mkPreludeDataConUnique 114 +unsafeReflDataConKey = mkPreludeDataConUnique 115 -- Multiplicity oneDataConKey, manyDataConKey :: Unique -oneDataConKey = mkPreludeDataConUnique 115 -manyDataConKey = mkPreludeDataConUnique 116 +oneDataConKey = mkPreludeDataConUnique 116 +manyDataConKey = mkPreludeDataConUnique 117 -- ghc-bignum integerISDataConKey, integerINDataConKey, integerIPDataConKey, @@ -2364,14 +2366,16 @@ mkTrFunKey = mkPreludeMiscIdUnique 510 -- Representations for primitive types trTYPEKey - ,trTYPE'PtrRepLiftedKey + , trTYPE'PtrRepLiftedKey , trRuntimeRepKey , tr'PtrRepLiftedKey + , trLiftedRepKey :: Unique trTYPEKey = mkPreludeMiscIdUnique 511 trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512 trRuntimeRepKey = mkPreludeMiscIdUnique 513 tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 514 +trLiftedRepKey = mkPreludeMiscIdUnique 515 -- KindReps for common cases starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique @@ -2601,4 +2605,5 @@ pretendNameIsInScope :: Name -> Bool pretendNameIsInScope n = any (n `hasKey`) [ liftedTypeKindTyConKey, tYPETyConKey - , runtimeRepTyConKey, liftedRepDataConKey ] + , runtimeRepTyConKey, boxedRepDataConKey + , liftedDataConKey ] diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 3339e0a020..3361853611 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -99,8 +99,9 @@ module GHC.Builtin.Types ( typeSymbolKindCon, typeSymbolKind, isLiftedTypeKindTyConName, liftedTypeKind, typeToTypeKind, constraintKind, + liftedRepTyCon, liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName, - liftedTypeKindTyConName, + liftedTypeKindTyConName, liftedRepTyConName, -- * Equality predicates heqTyCon, heqTyConName, heqClass, heqDataCon, @@ -108,13 +109,15 @@ module GHC.Builtin.Types ( coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, -- * RuntimeRep and friends - runtimeRepTyCon, vecCountTyCon, vecElemTyCon, + runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon, - runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon, + boxedRepDataConTyCon, + runtimeRepTy, liftedRepTy, unliftedRepTy, vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, - liftedRepDataConTy, unliftedRepDataConTy, + liftedDataConTyCon, unliftedDataConTyCon, + intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, @@ -212,6 +215,41 @@ 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This module include a lot of wired-in types and type constructors. Here, +these are presented in a tabular format to make it easier to find the +wired-in type identifier corresponding to a known Haskell type. Data +constructors are nested under their corresponding types with two spaces +of indentation. + +Identifier Type Haskell name Notes +---------------------------------------------------------------------------- +liftedTypeKindTyCon TyCon GHC.Types.Type Synonym for: TYPE LiftedRep +liftedRepTyCon TyCon GHC.Types.LiftedRep Synonym for: 'BoxedRep 'Lifted +levityTyCon TyCon GHC.Types.Levity Data type + liftedDataConTyCon TyCon GHC.Types.Lifted Data constructor + unliftedDataConTyCon TyCon GHC.Types.Unlifted Data constructor +vecCountTyCon TyCon GHC.Types.VecCount Data type + vec2DataConTy Type GHC.Types.Vec2 Data constructor + vec4DataConTy Type GHC.Types.Vec4 Data constructor + vec8DataConTy Type GHC.Types.Vec8 Data constructor + vec16DataConTy Type GHC.Types.Vec16 Data constructor + vec32DataConTy Type GHC.Types.Vec32 Data constructor + vec64DataConTy Type GHC.Types.Vec64 Data constructor +runtimeRepTyCon TyCon GHC.Types.RuntimeRep Data type + boxedRepDataConTyCon TyCon GHC.Types.BoxedRep Data constructor + intRepDataConTy Type GHC.Types.IntRep Data constructor + doubleRepDataConTy Type GHC.Types.DoubleRep Data constructor + floatRepDataConTy Type GHC.Types.FloatRep Data constructor +boolTyCon TyCon GHC.Types.Bool Data type + trueDataCon DataCon GHC.Types.True Data constructor + falseDataCon DataCon GHC.Types.False Data constructor + promotedTrueDataCon TyCon GHC.Types.True Data constructor + promotedFalseDataCon TyCon GHC.Types.False Data constructor + ************************************************************************ * * \subsection{Wired in type constructors} @@ -220,8 +258,10 @@ See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. If you change which things are wired in, make sure you change their names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc + -} + -- This list is used only to define GHC.Builtin.Utils.wiredInThings. That in turn -- is used to initialise the name environment carried around by the renamer. -- This means that if we look up the name of a TyCon (or its implicit binders) @@ -260,6 +300,7 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they , coercibleTyCon , typeSymbolKindCon , runtimeRepTyCon + , levityTyCon , vecCountTyCon , vecElemTyCon , constraintKindTyCon @@ -267,6 +308,7 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they , multiplicityTyCon , naturalTyCon , integerTyCon + , liftedRepTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -483,8 +525,9 @@ typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") constraintKindTyConName :: Name constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon -liftedTypeKindTyConName :: Name +liftedTypeKindTyConName, liftedRepTyConName :: Name liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon +liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") liftedRepTyConKey liftedRepTyCon multiplicityTyConName :: Name multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity") @@ -500,18 +543,24 @@ manyDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "Many") ma -- reported. Making them built-in make it so that they are always considered in -- scope. -runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name +runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon +boxedRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon + +levityTyConName, liftedDataConName, unliftedDataConName :: Name +levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon +liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon +unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon + -- See Note [Wiring in RuntimeRep] runtimeRepSimpleDataConNames :: [Name] runtimeRepSimpleDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "LiftedRep", fsLit "UnliftedRep" - , fsLit "IntRep" + [ fsLit "IntRep" , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep" , fsLit "WordRep" , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep" @@ -1413,16 +1462,43 @@ runtimeRepTy = mkTyConTy runtimeRepTyCon -- 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 'LiftedRep +-- type Type = TYPE ('BoxedRep 'Lifted) +-- type LiftedRep = 'BoxedRep 'Lifted liftedTypeKindTyCon :: TyCon liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs - where rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy] + where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp liftedRepTyCon []] + +liftedRepTyCon :: TyCon +liftedRepTyCon = buildSynTyCon + liftedRepTyConName [] runtimeRepTy [] liftedRepTy runtimeRepTyCon :: TyCon runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] - (vecRepDataCon : tupleRepDataCon : - sumRepDataCon : runtimeRepSimpleDataCons) + (vecRepDataCon : tupleRepDataCon : + sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons) + +levityTyCon :: TyCon +levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon] + +liftedDataCon, unliftedDataCon :: DataCon +liftedDataCon = pcSpecialDataCon liftedDataConName + [] levityTyCon LiftedInfo +unliftedDataCon = pcSpecialDataCon unliftedDataConName + [] levityTyCon UnliftedInfo + +boxedRepDataCon :: DataCon +boxedRepDataCon = pcSpecialDataCon boxedRepDataConName + [ mkTyConTy levityTyCon ] runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in RepType + prim_rep_fun [lev] + = case tyConRuntimeRepInfo (tyConAppTyCon lev) of + LiftedInfo -> [LiftedRep] + UnliftedInfo -> [UnliftedRep] + _ -> pprPanic "boxedRepDataCon" (ppr lev) + prim_rep_fun args + = pprPanic "boxedRepDataCon" (ppr args) vecRepDataCon :: DataCon vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon @@ -1477,11 +1553,9 @@ sumRepDataConTyCon = promoteDataCon sumRepDataCon -- See Note [Wiring in RuntimeRep] -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType runtimeRepSimpleDataCons :: [DataCon] -liftedRepDataCon :: DataCon -runtimeRepSimpleDataCons@(liftedRepDataCon : _) +runtimeRepSimpleDataCons = zipWithLazy mk_runtime_rep_dc - [ LiftedRep, UnliftedRep - , IntRep + [ IntRep , Int8Rep, Int16Rep, Int32Rep, Int64Rep , WordRep , Word8Rep, Word16Rep, Word32Rep, Word64Rep @@ -1494,15 +1568,13 @@ runtimeRepSimpleDataCons@(liftedRepDataCon : _) = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) -- See Note [Wiring in RuntimeRep] -liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, +intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type -[liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, +[intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, @@ -1554,12 +1626,29 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) vecElemDataCons -liftedRepDataConTyCon :: TyCon -liftedRepDataConTyCon = promoteDataCon liftedRepDataCon --- The type ('LiftedRep) +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 'LiftedRep) liftedRepTy :: Type -liftedRepTy = liftedRepDataConTy +liftedRepTy = mkTyConApp boxedRepDataConTyCon [liftedDataConTy] + +-- The type ('BoxedRep 'UnliftedRep) +unliftedRepTy :: Type +unliftedRepTy = mkTyConApp boxedRepDataConTyCon [unliftedDataConTy] {- ********************************************************************* * * diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot index 000df212c3..222d88fdf7 100644 --- a/compiler/GHC/Builtin/Types.hs-boot +++ b/compiler/GHC/Builtin/Types.hs-boot @@ -20,13 +20,16 @@ liftedTypeKindTyCon :: TyCon constraintKind :: Kind -runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon +runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon :: TyCon runtimeRepTy :: Type -liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon +boxedRepDataConTyCon :: TyCon +liftedDataConTyCon :: TyCon +vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -liftedRepDataConTy, unliftedRepDataConTy, - intRepDataConTy, +liftedRepTy, unliftedRepTy :: Type + +intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 61f341a0bb..e748258769 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -98,7 +98,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( runtimeRepTy, unboxedTupleKind, liftedTypeKind , vecRepDataConTyCon, tupleRepDataConTyCon - , liftedRepDataConTy, unliftedRepDataConTy + , liftedRepTy, unliftedRepTy , intRepDataConTy , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy , wordRepDataConTy @@ -364,7 +364,7 @@ alphaTy, betaTy, gammaTy, deltaTy :: Type (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys alphaTyVarsUnliftedRep :: [TyVar] -alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepDataConTy) +alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepTy) alphaTyVarUnliftedRep :: TyVar (alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep @@ -451,26 +451,28 @@ Note [TYPE and RuntimeRep] All types that classify values have a kind of the form (TYPE rr), where data RuntimeRep -- Defined in ghc-prim:GHC.Types - = LiftedRep - | UnliftedRep + = BoxedRep Levity | IntRep | FloatRep .. etc .. + data Levity = Lifted | Unlifted + rr :: RuntimeRep TYPE :: RuntimeRep -> TYPE 'LiftedRep -- Built in So for example: - Int :: TYPE 'LiftedRep - Array# Int :: TYPE 'UnliftedRep + Int :: TYPE ('BoxedRep 'Lifted) + Array# Int :: TYPE ('BoxedRep 'Unlifted) Int# :: TYPE 'IntRep Float# :: TYPE 'FloatRep - Maybe :: TYPE 'LiftedRep -> TYPE 'LiftedRep + Maybe :: TYPE ('BoxedRep 'Lifted) -> TYPE ('BoxedRep 'Lifted) (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) We abbreviate '*' specially: - type * = TYPE 'LiftedRep + type LiftedRep = 'BoxedRep 'Lifted + type * = TYPE LiftedRep The 'rr' parameter tells us how the value is represented at runtime. @@ -577,8 +579,8 @@ pcPrimTyCon name roles rep primRepToRuntimeRep :: PrimRep -> Type primRepToRuntimeRep rep = case rep of VoidRep -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] - LiftedRep -> liftedRepDataConTy - UnliftedRep -> unliftedRepDataConTy + LiftedRep -> liftedRepTy + UnliftedRep -> unliftedRepTy IntRep -> intRepDataConTy Int8Rep -> int8RepDataConTy Int16Rep -> int16RepDataConTy diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index be7bdb3aef..262037402b 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_HADDOCK not-home #-} @@ -91,7 +92,7 @@ import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -- others -import GHC.Builtin.Names ( liftedTypeKindTyConKey, liftedRepDataConKey, manyDataConKey, tYPETyConKey ) +import GHC.Builtin.Names ( liftedTypeKindTyConKey, boxedRepDataConKey, liftedDataConKey, manyDataConKey, tYPETyConKey ) import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, liftedTypeKind, manyDataConTy ) import {-# SOURCE #-} GHC.Builtin.Types.Prim ( tYPETyCon ) import GHC.Types.Basic ( LeftOrRight(..), pickLR ) @@ -1090,17 +1091,22 @@ See #17958. -- | Given a RuntimeRep, applies TYPE to it. -- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. tYPE :: Type -> Type -tYPE (TyConApp tc []) +tYPE rr@(TyConApp tc [arg]) -- See Note [Prefer Type of TYPE 'LiftedRep] - | tc `hasKey` liftedRepDataConKey = liftedTypeKind -- TYPE 'LiftedRep + | tc `hasKey` boxedRepDataConKey + , TyConApp tc' [] <- arg + = if | tc' `hasKey` liftedDataConKey -> liftedTypeKind + -- | tc' `hasKey` unlifedDataConKey -> unliftedTypeKind + | otherwise -> TyConApp tYPETyCon [rr] tYPE rr = TyConApp tYPETyCon [rr] -- This is a single, global definition of the type `Type` -- Defined here so it is only allocated once. --- See Note [Prefer Type over TYPE 'LiftedRep] in this module. +-- See Note [mkTyConApp and Type] in this module. liftedTypeKindTyConApp :: Type liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon [] + {- %************************************************************************ %* * diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index a038fd646c..e07e51e606 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -139,7 +139,7 @@ import {-# SOURCE #-} GHC.Core.TyCo.Rep import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) import {-# SOURCE #-} GHC.Builtin.Types - ( runtimeRepTyCon, constraintKind + ( runtimeRepTyCon, constraintKind, levityTyCon , multiplicityTyCon , vecCountTyCon, vecElemTyCon, liftedTypeKind ) import {-# SOURCE #-} GHC.Core.DataCon @@ -1073,6 +1073,8 @@ data RuntimeRepInfo -- be the list of arguments to the promoted datacon. | VecCount Int -- ^ A constructor of @VecCount@ | VecElem PrimElemRep -- ^ A constructor of @VecElem@ + | LiftedInfo + | UnliftedInfo -- | Extract those 'DataCon's that we are able to learn about. Note -- that visibility in this sense does not correspond to visibility in @@ -2235,8 +2237,8 @@ isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys -- -XDataKinds. kindTyConKeys :: UniqSet Unique kindTyConKeys = unionManyUniqSets - ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] - : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon + ( mkUniqSet [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey ] + : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon, levityTyCon , multiplicityTyCon , vecCountTyCon, vecElemTyCon ] ) where diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index e5d0da93fd..6065f3f56a 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -121,6 +121,7 @@ module GHC.Core.Type ( isLiftedType_maybe, isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind, isLiftedRuntimeRep, isUnliftedRuntimeRep, + isLiftedLevity, isUnliftedLevity, isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, isAlgType, isDataFamilyAppType, isPrimitiveType, isStrictType, @@ -611,6 +612,7 @@ isLiftedTypeKind kind pickyIsLiftedTypeKind :: Kind -> Bool -- Checks whether the kind is literally -- TYPE LiftedRep +-- or TYPE ('BoxedRep 'Lifted) -- or Type -- without expanding type synonyms or anything -- Used only when deciding whether to suppress the ":: *" in @@ -619,8 +621,13 @@ pickyIsLiftedTypeKind :: Kind -> Bool pickyIsLiftedTypeKind kind | TyConApp tc [arg] <- kind , tc `hasKey` tYPETyConKey - , TyConApp rr_tc [] <- arg - , rr_tc `hasKey` liftedRepDataConKey = True + , TyConApp rr_tc rr_args <- arg = case rr_args of + [] -> rr_tc `hasKey` liftedRepTyConKey + [rr_arg] + | rr_tc `hasKey` boxedRepDataConKey + , TyConApp lev [] <- rr_arg + , lev `hasKey` liftedDataConKey -> True + _ -> False | TyConApp tc [] <- kind , tc `hasKey` liftedTypeKindTyConKey = True | otherwise = False @@ -630,8 +637,27 @@ isLiftedRuntimeRep :: Type -> Bool -- False of type variables (a :: RuntimeRep) -- and of other reps e.g. (IntRep :: RuntimeRep) isLiftedRuntimeRep rep - | TyConApp rr_tc args <- coreFullView rep - , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True + | TyConApp rr_tc rr_args <- coreFullView rep + , rr_tc `hasKey` boxedRepDataConKey + = case rr_args of + [rr_arg] -> isLiftedLevity rr_arg + _ -> ASSERT( False ) True -- this should probably just panic + | otherwise = False + +isLiftedLevity :: Type -> Bool +isLiftedLevity lev + | Just lev' <- coreView lev = isLiftedLevity lev' + | TyConApp lev_tc lev_args <- lev + , lev_tc `hasKey` liftedDataConKey + = ASSERT( null lev_args ) True + | otherwise = False + +isUnliftedLevity :: Type -> Bool +isUnliftedLevity lev + | Just lev' <- coreView lev = isUnliftedLevity lev' + | TyConApp lev_tc lev_args <- lev + , lev_tc `hasKey` unliftedDataConKey + = ASSERT( null lev_args ) True | otherwise = False -- | Returns True if the kind classifies unlifted types and False otherwise. @@ -648,9 +674,15 @@ isUnliftedRuntimeRep :: Type -> Bool -- False of (LiftedRep :: RuntimeRep) -- and of variables (a :: RuntimeRep) isUnliftedRuntimeRep rep - | TyConApp rr_tc _ <- coreFullView rep -- NB: args might be non-empty - -- e.g. TupleRep [r1, .., rn] - = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) + | TyConApp rr_tc args <- coreFullView rep -- NB: args might be non-empty + -- e.g. TupleRep [r1, .., rn] + , isPromotedDataCon rr_tc = + -- NB: args might be non-empty e.g. TupleRep [r1, .., rn] + if (rr_tc `hasKey` boxedRepDataConKey) + then case args of + [TyConApp lev_tc []] -> lev_tc `hasKey` unliftedDataConKey + _ -> False + else True -- Avoid searching all the unlifted RuntimeRep type cons -- In the RuntimeRep data type, only LiftedRep is lifted -- But be careful of type families (F tys) :: RuntimeRep diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index e87998dd37..f6107a5318 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -77,8 +77,9 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( coercibleTyCon, heqTyCon - , liftedRepDataConTyCon, tupleTyConName - , manyDataConTyCon, oneDataConTyCon ) + , liftedDataConTyCon, tupleTyConName + , manyDataConTyCon, oneDataConTyCon + , boxedRepDataConTyCon ) import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy ) import GHC.Core.TyCon hiding ( pprPromotionQuote ) @@ -413,16 +414,36 @@ IfaceHoleCo to ensure that they don't end up in an interface file. ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key +-- | Given a kind K, is K of the form (TYPE ('BoxedRep 'LiftedRep))? isIfaceLiftedTypeKind :: IfaceKind -> Bool isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) = isLiftedTypeKindTyConName (ifaceTyConName tc) -isIfaceLiftedTypeKind (IfaceTyConApp tc - (IA_Arg (IfaceTyConApp ptr_rep_lifted IA_Nil) - Required IA_Nil)) - = tc `ifaceTyConHasKey` tYPETyConKey - && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey +isIfaceLiftedTypeKind (IfaceTyConApp tc1 args1) + = isIfaceTyConAppLiftedTypeKind tc1 args1 isIfaceLiftedTypeKind _ = False +-- | Given a kind constructor K and arguments A, returns true if +-- both of the following statements are true: +-- +-- * K is TYPE +-- * A is a singleton IfaceAppArgs of the form ('BoxedRep 'LiftedRep) +-- +-- For the second condition, we must also check for the type +-- synonym LiftedRep. +isIfaceTyConAppLiftedTypeKind :: IfaceTyCon -> IfaceAppArgs -> Bool +isIfaceTyConAppLiftedTypeKind tc1 args1 + | tc1 `ifaceTyConHasKey` tYPETyConKey + , IA_Arg soleArg1 Required IA_Nil <- args1 + , IfaceTyConApp rep args2 <- soleArg1 = + if | rep `ifaceTyConHasKey` boxedRepDataConKey + , IA_Arg soleArg2 Required IA_Nil <- args2 + , IfaceTyConApp lev IA_Nil <- soleArg2 + , lev `ifaceTyConHasKey` liftedDataConKey -> True + | rep `ifaceTyConHasKey` liftedRepTyConKey + , IA_Nil <- args2 -> True + | otherwise -> False + | otherwise = False + splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) -- Mainly for printing purposes -- @@ -1080,11 +1101,17 @@ defaultNonStandardVars do_runtimereps do_multiplicities ty = go False emptyFsEnv | do_multiplicities, tc `ifaceTyConHasKey` multiplicityTyConKey = Just many_ty check_substitution _ = Nothing +-- The type ('BoxedRep 'LiftedRep) liftedRep_ty :: IfaceType liftedRep_ty = - IfaceTyConApp (IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon)) - IA_Nil - where dc_name = getName liftedRepDataConTyCon + IfaceTyConApp boxedRep (IA_Arg (IfaceTyConApp lifted IA_Nil) Required IA_Nil) + where + boxedRep :: IfaceTyCon + boxedRep = IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) + where dc_name = getName boxedRepDataConTyCon + lifted :: IfaceTyCon + lifted = IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) + where dc_name = getName liftedDataConTyCon many_ty :: IfaceType many_ty = @@ -1408,9 +1435,7 @@ pprTyTcApp ctxt_prec tc tys = , isInvisibleArgFlag argf -> pprIfaceTyList ctxt_prec ty1 ty2 - | tc `ifaceTyConHasKey` tYPETyConKey - , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys - , rep `ifaceTyConHasKey` liftedRepDataConKey + | isIfaceTyConAppLiftedTypeKind tc tys , print_type_abbreviations -- See Note [Printing type abbreviations] -> ppr_kind_type ctxt_prec diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 71b919b4fd..605b3036c7 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1782,7 +1782,9 @@ headline_eq_msg :: Bool -> Ct -> Type -> Type -> SDoc headline_eq_msg add_ea ct ty1 ty2 | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || - (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) + (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || + (isLiftedLevity ty1 && isUnliftedLevity ty2) || + (isLiftedLevity ty2 && isUnliftedLevity ty1) = text "Couldn't match a lifted type with an unlifted type" | isAtomicTy ty1 || isAtomicTy ty2 diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index e4eb7a1b2d..ba01154785 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiWayIf #-} module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where @@ -28,7 +29,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( primTyCons ) import GHC.Builtin.Types ( tupleTyCon, sumTyCon, runtimeRepTyCon - , vecCountTyCon, vecElemTyCon + , levityTyCon, vecCountTyCon, vecElemTyCon , nilDataCon, consDataCon ) import GHC.Types.Name import GHC.Types.Id @@ -175,7 +176,7 @@ mkTypeableBinds } } } where needs_typeable_binds tc - | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon] + | tc `elem` [runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon] = False | otherwise = isAlgTyCon tc @@ -351,7 +352,7 @@ mkPrimTypeableTodos -- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat - [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon ] + [ [ runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon ] , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] , map sumTyCon [2..mAX_SUM_SIZE] , primTyCons @@ -555,9 +556,9 @@ mkKindRepRhs :: TypeableStuff -> CmEnv -- ^ in-scope kind variables -> Kind -- ^ the kind we want a 'KindRep' for -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression -mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep +mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep_shortcut where - new_kind_rep k + new_kind_rep_shortcut k -- We handle (TYPE LiftedRep) etc separately to make it -- clear to consumers (e.g. serializers) that there is -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep) @@ -565,9 +566,19 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep -- Typeable respects the Constraint/Type distinction -- so do not follow the special case here , Just arg <- kindRep_maybe k - , Just (tc, []) <- splitTyConApp_maybe arg - , Just dc <- isPromotedDataCon_maybe tc - = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc + = if + | Just (tc, []) <- splitTyConApp_maybe arg + , Just dc <- isPromotedDataCon_maybe tc + -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc + | Just (rep,[levArg]) <- splitTyConApp_maybe arg + , Just dcRep <- isPromotedDataCon_maybe rep + , Just (lev, []) <- splitTyConApp_maybe levArg + , Just dcLev <- isPromotedDataCon_maybe lev + -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` (nlHsDataCon dcRep `nlHsApp` nlHsDataCon dcLev) + | otherwise + -> new_kind_rep k + | otherwise = new_kind_rep k + new_kind_rep (TyVarTy v) | Just idx <- lookupCME in_scope v diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index 0ef8cfe9c9..2957dddb5d 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -361,10 +361,11 @@ but RuntimeRep has some extra cases: 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 ...etc... +data Levity = Lifted + | Unlifted It's all in 1-1 correspondence with PrimRep except for TupleRep and SumRep, which describe unboxed products and sums respectively. RuntimeRep is defined @@ -374,6 +375,13 @@ program, so that every variable has a type that has a PrimRep. For example, unarisation transforms our utup function above, to take two Int arguments instead of one (# Int, Int #) argument. +Also, note that boxed types are represented slightly differently in RuntimeRep +and PrimRep. PrimRep just has the nullary LiftedRep and UnliftedRep data +constructors. RuntimeRep has a BoxedRep data constructor, which accepts a +Levity. The subtle distinction is that since BoxedRep can accept a variable +argument, RuntimeRep can talk about levity polymorphic types. PrimRep, by +contrast, cannot. + See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. Note [VoidRep] diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index 1579eeb5a8..86f5fce3b4 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -864,7 +864,6 @@ instance Binary (Bin a) where get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) - -- ----------------------------------------------------------------------------- -- Lazy reading/writing diff --git a/compiler/GHC/Utils/Binary/Typeable.hs b/compiler/GHC/Utils/Binary/Typeable.hs index 580b245ded..ab96cf748c 100644 --- a/compiler/GHC/Utils/Binary/Typeable.hs +++ b/compiler/GHC/Utils/Binary/Typeable.hs @@ -19,6 +19,9 @@ import GHC.Prelude import GHC.Utils.Binary import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) +#if __GLASGOW_HASKELL__ >= 901 +import GHC.Exts (Levity(Lifted, Unlifted)) +#endif import GHC.Serialized import Foreign @@ -112,8 +115,13 @@ instance Binary RuntimeRep where put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps +#if __GLASGOW_HASKELL__ >= 901 + put_ bh (BoxedRep Lifted) = putByte bh 3 + put_ bh (BoxedRep Unlifted) = putByte bh 4 +#else put_ bh LiftedRep = putByte bh 3 put_ bh UnliftedRep = putByte bh 4 +#endif put_ bh IntRep = putByte bh 5 put_ bh WordRep = putByte bh 6 put_ bh Int64Rep = putByte bh 7 @@ -136,8 +144,13 @@ instance Binary RuntimeRep where 0 -> VecRep <$> get bh <*> get bh 1 -> TupleRep <$> get bh 2 -> SumRep <$> get bh +#if __GLASGOW_HASKELL__ >= 901 + 3 -> pure (BoxedRep Lifted) + 4 -> pure (BoxedRep Unlifted) +#else 3 -> pure LiftedRep 4 -> pure UnliftedRep +#endif 5 -> pure IntRep 6 -> pure WordRep 7 -> pure Int64Rep diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst index 283615b7a4..bfa8283092 100644 --- a/docs/users_guide/9.2.1-notes.rst +++ b/docs/users_guide/9.2.1-notes.rst @@ -13,6 +13,12 @@ Language <https://www.microsoft.com/en-us/research/publication/a-quick-look-at-impredicativity/>`__ (Serrano et al, ICFP 2020). More information here: :ref:`impredicative-polymorphism`. This replaces the old (undefined, flaky) behaviour of the :extension:`ImpredicativeTypes` extension. +* The first stage of the `Pointer Rep Proposal`_ has been implemented. All + boxed types, both lifted and unlifted, now have representation kinds of + the shape ``BoxedRep r``. Code that references ``LiftedRep`` and ``UnliftedRep`` + will need to be updated. + +.. _Pointer Rep Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0203-pointer-rep.rst * Kind inference for data/newtype instance declarations is slightly more restrictive than before. See the user manual :ref:`kind-inference-data-family-instances`. diff --git a/docs/users_guide/exts/levity_polymorphism.rst b/docs/users_guide/exts/levity_polymorphism.rst index a65f878b41..80a544e54b 100644 --- a/docs/users_guide/exts/levity_polymorphism.rst +++ b/docs/users_guide/exts/levity_polymorphism.rst @@ -13,21 +13,25 @@ Here are the key definitions, all available from ``GHC.Exts``: :: TYPE :: RuntimeRep -> Type -- highly magical, built into GHC - data RuntimeRep = LiftedRep -- for things like `Int` - | UnliftedRep -- for things like `Array#` - | IntRep -- for `Int#` + data Levity = Lifted -- for things like `Int` + | Unlifted -- for things like `Array#` + + data RuntimeRep = BoxedRep Levity -- for anything represented by a GC-managed pointer + | IntRep -- for `Int#` | TupleRep [RuntimeRep] -- unboxed tuples, indexed by the representations of the elements | SumRep [RuntimeRep] -- unboxed sums, indexed by the representations of the disjuncts | ... + type LiftedRep = BoxedRep Lifted + type Type = TYPE LiftedRep -- Type is just an ordinary type synonym The idea is that we have a new fundamental type constant ``TYPE``, which is parameterised by a ``RuntimeRep``. We thus get ``Int# :: TYPE 'IntRep`` -and ``Bool :: TYPE 'LiftedRep``. Anything with a type of the form +and ``Bool :: TYPE LiftedRep``. Anything with a type of the form ``TYPE x`` can appear to either side of a function arrow ``->``. We can thus say that ``->`` has type -``TYPE r1 -> TYPE r2 -> TYPE 'LiftedRep``. The result is always lifted +``TYPE r1 -> TYPE r2 -> TYPE LiftedRep``. The result is always lifted because all functions are lifted in GHC. .. _levity-polymorphic-restrictions: @@ -102,13 +106,13 @@ Printing levity-polymorphic types :category: verbosity Print ``RuntimeRep`` parameters as they appear; otherwise, they are - defaulted to ``'LiftedRep``. + defaulted to ``LiftedRep``. Most GHC users will not need to worry about levity polymorphism or unboxed types. For these users, seeing the levity polymorphism in the type of ``$`` is unhelpful. And thus, by default, it is suppressed, -by supposing all type variables of type ``RuntimeRep`` to be ``'LiftedRep`` -when printing, and printing ``TYPE 'LiftedRep`` as ``Type`` (or ``*`` when +by supposing all type variables of type ``RuntimeRep`` to be ``LiftedRep`` +when printing, and printing ``TYPE LiftedRep`` as ``Type`` (or ``*`` when :extension:`StarIsType` is on). Should you wish to see levity polymorphism in your types, enable diff --git a/docs/users_guide/exts/typed_holes.rst b/docs/users_guide/exts/typed_holes.rst index 170824ee4f..4fded59ae2 100644 --- a/docs/users_guide/exts/typed_holes.rst +++ b/docs/users_guide/exts/typed_holes.rst @@ -443,7 +443,7 @@ it will additionally offer up a list of refinement hole fits, in this case: :: with const @Integer @[Integer] where const :: forall a b. a -> b -> a ($) (_ :: [Integer] -> Integer) - with ($) @'GHC.Types.LiftedRep @[Integer] @Integer + with ($) @GHC.Types.LiftedRep @[Integer] @Integer where ($) :: forall a b. (a -> b) -> a -> b fail (_ :: String) with fail @((->) [Integer]) @Integer 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 85abebf331..de20ca8e19 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 #-} @@ -80,6 +81,9 @@ module Data.Typeable.Internal ( mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun, mkTyCon, mkTyCon#, typeSymbolTypeRep, typeNatTypeRep, + + -- Jank + 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 @@ -399,23 +408,23 @@ mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). -> TypeRep (b :: k1) -> TypeRep (a b) mkTrApp a b -- See Note [Kind caching], Wrinkle 2 - | Just HRefl <- a `eqTypeRep` trTYPE - , Just HRefl <- b `eqTypeRep` trLiftedRep - = TrType - - | TrFun {trFunRes = res_kind} <- typeRepKind a - = TrApp - { trAppFingerprint = fpr - , trAppFun = a - , trAppArg = b - , trAppKind = res_kind } - - | otherwise = error ("Ill-kinded type application: " - ++ show (typeRepKind a)) - where - fpr_a = typeRepFingerprint a - fpr_b = typeRepFingerprint b - fpr = fingerprintFingerprints [fpr_a, fpr_b] + | Just HRefl <- a `eqTypeRep` trTYPE + , Just HRefl <- b `eqTypeRep` trLiftedRep + = TrType + + | TrFun {trFunRes = res_kind} <- typeRepKind a + = TrApp + { trAppFingerprint = fpr + , trAppFun = a + , trAppArg = b + , trAppKind = res_kind } + + | otherwise = error ("Ill-kinded type application: " + ++ show (typeRepKind a)) + where + fpr_a = typeRepFingerprint a + fpr_b = typeRepFingerprint b + fpr = fingerprintFingerprints [fpr_a, fpr_b] -- | Construct a representation for a type application that -- may be a saturated arrow type. This is renamed to mkTrApp in @@ -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 54d6c6b34a..7bf00f490d 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.15.0.0 +deriving instance Bounded Levity +-- | @since 4.15.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 31788c24c0..087427e84a 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -91,7 +91,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 3de7aca723..bf8ced5312 100644 --- a/libraries/base/GHC/Show.hs +++ b/libraries/base/GHC/Show.hs @@ -594,6 +594,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 6792592254..ae8c64145a 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 -Subproject b224410161f112dd1133a787ded9831799589ce +Subproject f22b3d34bb46f95ec5a23d1ef894e2a05818a78 diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs index 2dfe788406..70ee2f0ecf 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap.hs @@ -90,10 +90,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 dc81a9b8d3..2f9130425a 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -33,7 +33,7 @@ module GHC.Types ( Symbol, Any, type (~~), Coercible, - TYPE, RuntimeRep(..), Type, Constraint, + TYPE, Levity(..), RuntimeRep(..), LiftedRep, Type, 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 +85,11 @@ type (->) = FUN 'Many -- | The kind of constraints, like @Show a@ data Constraint +-- | The runtime representation of lifted types. +type LiftedRep = 'BoxedRep 'Lifted + -- | The kind of types with lifted values. For example @Int :: Type@. -type Type = TYPE 'LiftedRep +type Type = TYPE LiftedRep data Multiplicity = Many | One @@ -410,6 +413,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 +430,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 +448,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 a3104ed684..c7d5c81c68 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 diff --git a/testsuite/tests/backpack/should_run/T13955.bkp b/testsuite/tests/backpack/should_run/T13955.bkp index a7d447f169..eadeee6f5c 100644 --- a/testsuite/tests/backpack/should_run/T13955.bkp +++ b/testsuite/tests/backpack/should_run/T13955.bkp @@ -18,7 +18,7 @@ unit number-unknown where unit number-int where module NumberUnknown where import GHC.Types - type Rep = LiftedRep + type Rep = 'BoxedRep 'Lifted type Number = Int plus :: Int -> Int -> Int plus = (+) diff --git a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs index 6c74e10a7c..90a72c2a9a 100644 --- a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs +++ b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs @@ -14,12 +14,14 @@ import Data.Type.Bool import Data.Type.Equality hiding ((:~~:)(..)) import GHC.TypeLits import Data.Proxy -import GHC.Exts +import GHC.Exts hiding (Lifted, BoxedRep) import Data.Kind import Unsafe.Coerce import Data.Char import Data.Maybe +import qualified GHC.Exts as Exts + ------------------------------- -- Utilities @@ -82,7 +84,9 @@ data TyCon (a :: k) where Arrow :: TyCon (->) TYPE :: TyCon TYPE RuntimeRep :: TyCon RuntimeRep - LiftedRep' :: TyCon 'LiftedRep + Levity :: TyCon Levity + BoxedRep :: TyCon 'Exts.BoxedRep + Lifted :: TyCon 'Exts.Lifted -- If extending, add to eqTyCon too eqTyCon :: TyCon a -> TyCon b -> Maybe (a :~~: b) @@ -94,7 +98,9 @@ eqTyCon Maybe Maybe = Just HRefl eqTyCon Arrow Arrow = Just HRefl eqTyCon TYPE TYPE = Just HRefl eqTyCon RuntimeRep RuntimeRep = Just HRefl -eqTyCon LiftedRep' LiftedRep' = Just HRefl +eqTyCon Levity Levity = Just HRefl +eqTyCon BoxedRep BoxedRep = Just HRefl +eqTyCon Lifted Lifted = Just HRefl eqTyCon _ _ = Nothing -- Check whether or not a type is really a plain old tycon; @@ -212,8 +218,10 @@ instance TyConAble [] where tyCon = List instance TyConAble Maybe where tyCon = Maybe instance TyConAble (->) where tyCon = Arrow instance TyConAble TYPE where tyCon = TYPE -instance TyConAble 'LiftedRep where tyCon = LiftedRep' -instance TyConAble RuntimeRep where tyCon = RuntimeRep +instance TyConAble 'Exts.Lifted where tyCon = Lifted +instance TyConAble 'Exts.BoxedRep where tyCon = BoxedRep +instance TyConAble RuntimeRep where tyCon = RuntimeRep +instance TyConAble Levity where tyCon = Levity -- Can't just define Typeable the way we want, because the instances -- overlap. So we have to mock up instance chains via closed type families. diff --git a/testsuite/tests/dependent/should_fail/T17131.stderr b/testsuite/tests/dependent/should_fail/T17131.stderr index daad6ac054..b2af8ab7b8 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: '[ 'LiftedRep] + with: '[ 'BoxedRep 'Lifted] Expected kind ‘TYPE ('TupleRep (TypeReps xs))’, - but ‘(# a #)’ has kind ‘TYPE ('TupleRep '[ 'LiftedRep])’ + but ‘(# a #)’ has kind ‘TYPE ('TupleRep '[ 'BoxedRep 'Lifted])’ The type variable ‘xs’ is ambiguous • In the type ‘(# a #)’ In the type family declaration for ‘Tuple#’ diff --git a/testsuite/tests/deriving/should_compile/T13154b.hs b/testsuite/tests/deriving/should_compile/T13154b.hs index 9df828b111..585f010eba 100644 --- a/testsuite/tests/deriving/should_compile/T13154b.hs +++ b/testsuite/tests/deriving/should_compile/T13154b.hs @@ -24,10 +24,10 @@ deriving instance Foo1 a class Foo2 (a :: TYPE ('TupleRep '[])) deriving instance Foo2 (##) -class Foo3 (a :: TYPE ('SumRep '[ 'LiftedRep, 'LiftedRep ])) +class Foo3 (a :: TYPE ('SumRep '[ 'BoxedRep 'Lifted, 'BoxedRep 'Lifted ])) deriving instance Foo3 a -class Foo4 (a :: TYPE ('SumRep '[ 'LiftedRep, 'LiftedRep ])) +class Foo4 (a :: TYPE ('SumRep '[ 'BoxedRep 'Lifted, 'BoxedRep 'Lifted ])) deriving instance Foo4 (# a | b #) class Foo5 (a :: Type) diff --git a/testsuite/tests/deriving/should_fail/T12512.hs b/testsuite/tests/deriving/should_fail/T12512.hs index 804bfd31da..61410d84cf 100644 --- a/testsuite/tests/deriving/should_fail/T12512.hs +++ b/testsuite/tests/deriving/should_fail/T12512.hs @@ -6,8 +6,8 @@ module T12512 where import GHC.Exts -class Wat1 (a :: TYPE ('TupleRep ['LiftedRep, 'LiftedRep])) +class Wat1 (a :: TYPE ('TupleRep ['BoxedRep 'Lifted, 'BoxedRep 'Lifted])) deriving instance Wat1 (# a, b #) -class Wat2 (a :: TYPE ('SumRep ['LiftedRep, 'LiftedRep])) +class Wat2 (a :: TYPE ('SumRep ['BoxedRep 'Lifted, 'BoxedRep 'Lifted])) deriving instance Wat2 (# a | b #) diff --git a/testsuite/tests/ffi/should_run/T16650a.hs b/testsuite/tests/ffi/should_run/T16650a.hs index 6a43a55118..65fc38b57d 100644 --- a/testsuite/tests/ffi/should_run/T16650a.hs +++ b/testsuite/tests/ffi/should_run/T16650a.hs @@ -27,7 +27,7 @@ foreign import ccall unsafe "head_bytearray" c_head_bytearray :: MutableByteArray# RealWorld -> IO Word8 data Box :: Type where - Box :: (Any :: TYPE 'UnliftedRep) -> Box + Box :: (Any :: TYPE ('BoxedRep 'Unlifted)) -> Box data MutableByteArray :: Type where MutableByteArray :: MutableByteArray# RealWorld -> MutableByteArray diff --git a/testsuite/tests/ffi/should_run/T16650b.hs b/testsuite/tests/ffi/should_run/T16650b.hs index ba0d4a72a0..265e5bf65f 100644 --- a/testsuite/tests/ffi/should_run/T16650b.hs +++ b/testsuite/tests/ffi/should_run/T16650b.hs @@ -31,7 +31,7 @@ foreign import ccall unsafe "is_doubleton_homogenous" c_is_doubleton_homogeneous :: MutableArrayArray# RealWorld -> IO Word8 data Box :: Type where - Box :: (Any :: TYPE 'UnliftedRep) -> Box + Box :: (Any :: TYPE ('BoxedRep 'Unlifted)) -> Box -- An array of bytes data MutableByteArray :: Type where diff --git a/testsuite/tests/ffi/should_run/T16650c.hs b/testsuite/tests/ffi/should_run/T16650c.hs index 968731b3bd..0d8e9ac8ec 100644 --- a/testsuite/tests/ffi/should_run/T16650c.hs +++ b/testsuite/tests/ffi/should_run/T16650c.hs @@ -26,7 +26,7 @@ foreign import ccall unsafe "is_doubleton_homogenous" MutableArray# RealWorld a -> IO Word8 data Box :: Type where - Box :: (Any :: TYPE 'UnliftedRep) -> Box + Box :: (Any :: TYPE ('BoxedRep 'Unlifted)) -> Box -- An array of unary integer functions data MutableArray :: Type where diff --git a/testsuite/tests/ffi/should_run/T16650d.hs b/testsuite/tests/ffi/should_run/T16650d.hs index 8bb4a4697b..874701b40a 100644 --- a/testsuite/tests/ffi/should_run/T16650d.hs +++ b/testsuite/tests/ffi/should_run/T16650d.hs @@ -26,7 +26,7 @@ foreign import ccall unsafe "is_doubleton_homogenous" SmallMutableArray# RealWorld a -> IO Word8 data Box :: Type where - Box :: (Any :: TYPE 'UnliftedRep) -> Box + Box :: (Any :: TYPE ('BoxedRep 'Unlifted)) -> Box -- An array of unary integer functions data SmallMutableArray :: Type where diff --git a/testsuite/tests/ffi/should_run/UnliftedNewtypesByteArrayOffset.hs b/testsuite/tests/ffi/should_run/UnliftedNewtypesByteArrayOffset.hs index 8953e9b02d..7a0a5cce19 100644 --- a/testsuite/tests/ffi/should_run/UnliftedNewtypesByteArrayOffset.hs +++ b/testsuite/tests/ffi/should_run/UnliftedNewtypesByteArrayOffset.hs @@ -19,7 +19,7 @@ foreign import ccall unsafe "head_bytearray" foreign import ccall unsafe "head_bytearray" c_head_bytearray_b :: MyArray# -> IO Word8 -newtype MyArray# :: TYPE 'UnliftedRep where +newtype MyArray# :: TYPE ('BoxedRep 'Unlifted) where MyArray# :: MutableByteArray# RealWorld -> MyArray# data MutableByteArray :: Type where diff --git a/testsuite/tests/ghci/scripts/T13963.script b/testsuite/tests/ghci/scripts/T13963.script index c5e830aad1..030e8087a9 100644 --- a/testsuite/tests/ghci/scripts/T13963.script +++ b/testsuite/tests/ghci/scripts/T13963.script @@ -1,5 +1,5 @@ :set -XPolyKinds -XDataKinds -XRankNTypes -import GHC.Exts (TYPE, RuntimeRep(LiftedRep)) +import GHC.Exts (TYPE, RuntimeRep, LiftedRep) type Pair (a :: TYPE rep) (b :: TYPE rep') rep'' = forall (r :: TYPE rep''). (a -> b -> r) :kind Pair :kind Pair Int diff --git a/testsuite/tests/ghci/scripts/T15941.stdout b/testsuite/tests/ghci/scripts/T15941.stdout index f9e6d339f9..803aa9ebd0 100644 --- a/testsuite/tests/ghci/scripts/T15941.stdout +++ b/testsuite/tests/ghci/scripts/T15941.stdout @@ -1,4 +1,4 @@ type T :: * -> * -> * type T = - (->) @{'GHC.Types.LiftedRep} @{'GHC.Types.LiftedRep} :: * -> * -> * + (->) @{GHC.Types.LiftedRep} @{GHC.Types.LiftedRep} :: * -> * -> * -- Defined at <interactive>:2:1 diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index b86ea432ff..8967544004 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -38,7 +38,8 @@ type (#,#) :: * -> * -> TYPE ('GHC.Types.TupleRep - '[ 'GHC.Types.LiftedRep, 'GHC.Types.LiftedRep]) + '[ 'GHC.Types.BoxedRep 'GHC.Types.Lifted, + 'GHC.Types.BoxedRep 'GHC.Types.Lifted]) data (#,#) a b = (#,#) a b -- Defined in ‘GHC.Prim’ (,) :: a -> b -> (a, b) diff --git a/testsuite/tests/ghci/should_run/T16096.stdout b/testsuite/tests/ghci/should_run/T16096.stdout index 5826057d42..2749f06586 100644 --- a/testsuite/tests/ghci/should_run/T16096.stdout +++ b/testsuite/tests/ghci/should_run/T16096.stdout @@ -17,7 +17,7 @@ GHC.Base.returnIO (GHC.Types.: @() (Unsafe.Coerce.unsafeCoerce# - @'GHC.Types.LiftedRep @'GHC.Types.LiftedRep @[GHC.Types.Int] @() x) + @GHC.Types.LiftedRep @GHC.Types.LiftedRep @[GHC.Types.Int] @() x) (GHC.Types.[] @())) @@ -40,7 +40,7 @@ GHC.Base.returnIO (GHC.Types.: @() (Unsafe.Coerce.unsafeCoerce# - @'GHC.Types.LiftedRep @'GHC.Types.LiftedRep @[GHC.Types.Int] @() x) + @GHC.Types.LiftedRep @GHC.Types.LiftedRep @[GHC.Types.Int] @() x) (GHC.Types.[] @())) diff --git a/testsuite/tests/ghci/should_run/T18594.stdout b/testsuite/tests/ghci/should_run/T18594.stdout index 9e2e79cd8b..d3219de45e 100644 --- a/testsuite/tests/ghci/should_run/T18594.stdout +++ b/testsuite/tests/ghci/should_run/T18594.stdout @@ -8,8 +8,8 @@ instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ type Type :: * -type Type = TYPE 'LiftedRep +type Type = TYPE LiftedRep -- Defined in ‘GHC.Types’ type Type :: Type -type Type = TYPE 'LiftedRep +type Type = TYPE LiftedRep -- Defined in ‘GHC.Types’ diff --git a/testsuite/tests/plugins/plugins09.stdout b/testsuite/tests/plugins/plugins09.stdout index 61f96283ff..776f34b5f3 100644 --- a/testsuite/tests/plugins/plugins09.stdout +++ b/testsuite/tests/plugins/plugins09.stdout @@ -3,5 +3,6 @@ interfacePlugin: Prelude interfacePlugin: GHC.Float interfacePlugin: GHC.Base 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 37f424b076..47e7d29b93 100644 --- a/testsuite/tests/plugins/plugins10.stdout +++ b/testsuite/tests/plugins/plugins10.stdout @@ -6,6 +6,7 @@ interfacePlugin: GHC.Float interfacePlugin: GHC.Base 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 6bab3559b1..b3e835f2bf 100644 --- a/testsuite/tests/plugins/plugins11.stdout +++ b/testsuite/tests/plugins/plugins11.stdout @@ -3,5 +3,6 @@ interfacePlugin: Prelude interfacePlugin: GHC.Float interfacePlugin: GHC.Base 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 032992824f..65af518b7f 100644 --- a/testsuite/tests/plugins/static-plugins.stdout +++ b/testsuite/tests/plugins/static-plugins.stdout @@ -5,11 +5,11 @@ interfacePlugin: GHC.Float interfacePlugin: GHC.Base interfacePlugin: System.IO typeCheckPlugin (rn) +interfacePlugin: GHC.Prim interfacePlugin: GHC.Types interfacePlugin: GHC.Show interfacePlugin: GHC.TopHandler typeCheckPlugin (tc) -interfacePlugin: GHC.Prim interfacePlugin: GHC.CString interfacePlugin: GHC.Num.BigNat ==pure.1 diff --git a/testsuite/tests/pmcheck/should_compile/T18249.hs b/testsuite/tests/pmcheck/should_compile/T18249.hs index b9bd048cbd..2a343b08e1 100644 --- a/testsuite/tests/pmcheck/should_compile/T18249.hs +++ b/testsuite/tests/pmcheck/should_compile/T18249.hs @@ -14,7 +14,7 @@ f :: Int# -> Int f !_ | False = 1 f _ = 2 -newtype UVoid :: TYPE 'UnliftedRep where +newtype UVoid :: TYPE ('BoxedRep 'Unlifted) where UVoid :: UVoid -> UVoid g :: UVoid -> Int diff --git a/testsuite/tests/polykinds/T14555.stderr b/testsuite/tests/polykinds/T14555.stderr index 3861872124..f85c1b44cc 100644 --- a/testsuite/tests/polykinds/T14555.stderr +++ b/testsuite/tests/polykinds/T14555.stderr @@ -1,6 +1,6 @@ T14555.hs:12:34: error: - • Couldn't match kind ‘rep’ with ‘'GHC.Types.LiftedRep’ + • Couldn't match kind ‘rep’ with ‘GHC.Types.LiftedRep’ Expected kind ‘TYPE rep’, but ‘a -> b’ has kind ‘*’ • In the second argument of ‘Exp’, namely ‘(a -> b)’ In the type ‘Exp xs (a -> b)’ diff --git a/testsuite/tests/polykinds/T14563.stderr b/testsuite/tests/polykinds/T14563.stderr index 2d81507659..e2dd07a6d6 100644 --- a/testsuite/tests/polykinds/T14563.stderr +++ b/testsuite/tests/polykinds/T14563.stderr @@ -1,6 +1,6 @@ T14563.hs:9:39: error: - • Couldn't match kind ‘rep''’ with ‘'GHC.Types.LiftedRep’ + • Couldn't match kind ‘rep''’ with ‘GHC.Types.LiftedRep’ Expected kind ‘TYPE rep -> TYPE rep''’, but ‘h’ has kind ‘TYPE rep -> *’ • In the second argument of ‘Lan’, namely ‘h’ diff --git a/testsuite/tests/polykinds/T17963.stderr b/testsuite/tests/polykinds/T17963.stderr index e38d216faf..aa0e4d0d3e 100644 --- a/testsuite/tests/polykinds/T17963.stderr +++ b/testsuite/tests/polykinds/T17963.stderr @@ -1,6 +1,6 @@ T17963.hs:15:23: error: - • Couldn't match kind ‘rep’ with ‘'LiftedRep’ + • Couldn't match kind ‘rep’ with ‘GHC.Types.LiftedRep’ When matching kinds k0 :: * ob :: TYPE rep diff --git a/testsuite/tests/polykinds/T18300.stderr b/testsuite/tests/polykinds/T18300.stderr index 53ea72b1b8..3ddd175d55 100644 --- a/testsuite/tests/polykinds/T18300.stderr +++ b/testsuite/tests/polykinds/T18300.stderr @@ -1,4 +1,2 @@ -T18300.hs:13:1: error: - • Data instance has non-* return kind ‘TYPE (F Int)’ - • In the data instance declaration for ‘T’ +T18300.hs:9:23: error: Not in scope: data constructor ‘LiftedRep’ diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr index 20cb606cb4..1f9a70946a 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.stderr +++ b/testsuite/tests/simplCore/should_compile/T18013.stderr @@ -129,9 +129,9 @@ Rule fired: Class op fmap (BUILTIN) ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 52, types: 101, coercions: 17, joins: 0/1} + = {terms: 52, types: 102, coercions: 17, joins: 0/1} --- RHS size: {terms: 37, types: 84, coercions: 17, joins: 0/1} +-- RHS size: {terms: 37, types: 85, coercions: 17, joins: 0/1} mapMaybeRule :: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b) [GblId, diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr index 9e3f4184ea..3b53d2cb02 100644 --- a/testsuite/tests/simplCore/should_compile/T9400.stderr +++ b/testsuite/tests/simplCore/should_compile/T9400.stderr @@ -65,7 +65,7 @@ main @() (putStrLn (unpackCString# "efg"#)) (Control.Exception.Base.patError - @'LiftedRep @(IO ()) "T9400.hs:(17,5)-(18,29)|case"#)))) + @LiftedRep @(IO ()) "T9400.hs:(17,5)-(18,29)|case"#)))) diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 87e8bd7980..a26d2ed3bc 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -48,7 +48,7 @@ lvl = "spec-inline.hs:(19,5)-(29,25)|function go"# Roman.foo3 :: Int [GblId, Str=b, Cpr=b] Roman.foo3 - = Control.Exception.Base.patError @'GHC.Types.LiftedRep @Int lvl + = Control.Exception.Base.patError @GHC.Types.LiftedRep @Int lvl Rec { -- RHS size: {terms: 40, types: 5, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/th/T14869.hs b/testsuite/tests/th/T14869.hs index 4b0dcdc171..5bd2a0806a 100644 --- a/testsuite/tests/th/T14869.hs +++ b/testsuite/tests/th/T14869.hs @@ -9,7 +9,7 @@ import GHC.Exts import Language.Haskell.TH (pprint, reify, stringE) type MyConstraint = Constraint -type MyLiftedRep = LiftedRep +type MyLiftedRep = BoxedRep Lifted type family Foo1 :: Type type family Foo2 :: Constraint diff --git a/testsuite/tests/typecheck/should_compile/LevPolyResult.hs b/testsuite/tests/typecheck/should_compile/LevPolyResult.hs new file mode 100644 index 0000000000..6c17d5c9ae --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/LevPolyResult.hs @@ -0,0 +1,11 @@ +{-# language DataKinds #-} +{-# language KindSignatures #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} + +module LevPolyResult (example) where + +import GHC.Exts + +example :: forall (v :: Levity) (a :: TYPE ('BoxedRep v)). (Int -> a) -> a +example f = f 42 diff --git a/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnassociatedFamily.hs b/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnassociatedFamily.hs index 0a8143b0b6..dd7890d33c 100644 --- a/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnassociatedFamily.hs +++ b/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnassociatedFamily.hs @@ -12,14 +12,15 @@ module UnliftedNewtypesUnassociatedFamily where import GHC.Int (Int(I#)) import GHC.Word (Word(W#)) import GHC.Exts (Int#,Word#) -import GHC.Exts (TYPE,RuntimeRep(LiftedRep,IntRep,WordRep,TupleRep)) +import GHC.Exts (TYPE,Levity(Lifted)) +import GHC.Exts (RuntimeRep(BoxedRep,IntRep,WordRep,TupleRep)) data family DFT (r :: RuntimeRep) :: TYPE r newtype instance DFT 'IntRep = MkDFT1 Int# newtype instance DFT 'WordRep = MkDFT2 Word# newtype instance DFT ('TupleRep '[ 'IntRep, 'WordRep]) = MkDFT3 (# Int#, Word# #) -data instance DFT 'LiftedRep = MkDFT4 | MkDFT5 +data instance DFT ('BoxedRep 'Lifted) = MkDFT4 | MkDFT5 data family DF :: TYPE (r :: RuntimeRep) diff --git a/testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr b/testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr index 57214ba181..61ed517535 100644 --- a/testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr +++ b/testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr @@ -33,20 +33,20 @@ abstract_refinement_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] (a -> b -> b) -> b -> t a -> b const (_ :: Integer) where const :: forall a b. a -> b -> a - ($) (_ :: [Integer] -> Integer) - where ($) :: forall a b. (a -> b) -> a -> b - ($!) (_ :: [Integer] -> Integer) - where ($!) :: forall a b. (a -> b) -> a -> b curry (_ :: (t0, [Integer]) -> Integer) (_ :: t0) where curry :: forall a b c. ((a, b) -> c) -> a -> b -> c (.) (_ :: b1 -> Integer) (_ :: [Integer] -> b1) where (.) :: forall b c a. (b -> c) -> (a -> b) -> a -> c flip (_ :: [Integer] -> t0 -> Integer) (_ :: t0) where flip :: forall a b c. (a -> b -> c) -> b -> a -> c + ($) (_ :: [Integer] -> Integer) + where ($) :: forall a b. (a -> b) -> a -> b return (_ :: Integer) where return :: forall (m :: * -> *) a. Monad m => a -> m a pure (_ :: Integer) where pure :: forall (f :: * -> *) a. Applicative f => a -> f a + ($!) (_ :: [Integer] -> Integer) + where ($!) :: forall a b. (a -> b) -> a -> b (>>=) (_ :: [Integer] -> a8) (_ :: a8 -> [Integer] -> Integer) where (>>=) :: forall (m :: * -> *) a b. Monad m => @@ -109,18 +109,18 @@ abstract_refinement_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] where snd :: forall a b. (a, b) -> b const (_ :: [Integer] -> Integer) (_ :: t0) where const :: forall a b. a -> b -> a + uncurry (_ :: a3 -> b3 -> [Integer] -> Integer) (_ :: (a3, b3)) + where uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c seq (_ :: t2) (_ :: [Integer] -> Integer) where seq :: forall a b. a -> b -> b ($) (_ :: t0 -> [Integer] -> Integer) (_ :: t0) where ($) :: forall a b. (a -> b) -> a -> b - uncurry (_ :: a3 -> b3 -> [Integer] -> Integer) (_ :: (a3, b3)) - where uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c - ($!) (_ :: t0 -> [Integer] -> Integer) (_ :: t0) - where ($!) :: forall a b. (a -> b) -> a -> b return (_ :: [Integer] -> Integer) (_ :: t0) where return :: forall (m :: * -> *) a. Monad m => a -> m a pure (_ :: [Integer] -> Integer) (_ :: t0) where pure :: forall (f :: * -> *) a. Applicative f => a -> f a + ($!) (_ :: t0 -> [Integer] -> Integer) (_ :: t0) + where ($!) :: forall a b. (a -> b) -> a -> b abstract_refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Integer -> [Integer] -> Integer @@ -148,20 +148,20 @@ abstract_refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] where flip :: forall a b c. (a -> b -> c) -> b -> a -> c const (_ :: [Integer] -> Integer) where const :: forall a b. a -> b -> a - ($) (_ :: Integer -> [Integer] -> Integer) - where ($) :: forall a b. (a -> b) -> a -> b - ($!) (_ :: Integer -> [Integer] -> Integer) - where ($!) :: forall a b. (a -> b) -> a -> b curry (_ :: (t0, Integer) -> [Integer] -> Integer) (_ :: t0) where curry :: forall a b c. ((a, b) -> c) -> a -> b -> c (.) (_ :: b1 -> [Integer] -> Integer) (_ :: Integer -> b1) where (.) :: forall b c a. (b -> c) -> (a -> b) -> a -> c flip (_ :: Integer -> t0 -> [Integer] -> Integer) (_ :: t0) where flip :: forall a b c. (a -> b -> c) -> b -> a -> c + ($) (_ :: Integer -> [Integer] -> Integer) + where ($) :: forall a b. (a -> b) -> a -> b return (_ :: [Integer] -> Integer) where return :: forall (m :: * -> *) a. Monad m => a -> m a pure (_ :: [Integer] -> Integer) where pure :: forall (f :: * -> *) a. Applicative f => a -> f a + ($!) (_ :: Integer -> [Integer] -> Integer) + where ($!) :: forall a b. (a -> b) -> a -> b (>>=) (_ :: Integer -> a8) (_ :: a8 -> Integer -> [Integer] -> Integer) where (>>=) :: forall (m :: * -> *) a b. @@ -228,16 +228,16 @@ abstract_refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] where snd :: forall a b. (a, b) -> b const (_ :: Integer -> [Integer] -> Integer) (_ :: t0) where const :: forall a b. a -> b -> a + uncurry (_ :: a3 -> b3 -> Integer -> [Integer] -> Integer) + (_ :: (a3, b3)) + where uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c seq (_ :: t2) (_ :: Integer -> [Integer] -> Integer) where seq :: forall a b. a -> b -> b ($) (_ :: t0 -> Integer -> [Integer] -> Integer) (_ :: t0) where ($) :: forall a b. (a -> b) -> a -> b - uncurry (_ :: a3 -> b3 -> Integer -> [Integer] -> Integer) - (_ :: (a3, b3)) - where uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c - ($!) (_ :: t0 -> Integer -> [Integer] -> Integer) (_ :: t0) - where ($!) :: forall a b. (a -> b) -> a -> b return (_ :: Integer -> [Integer] -> Integer) (_ :: t0) where return :: forall (m :: * -> *) a. Monad m => a -> m a pure (_ :: Integer -> [Integer] -> Integer) (_ :: t0) where pure :: forall (f :: * -> *) a. Applicative f => a -> f a + ($!) (_ :: t0 -> Integer -> [Integer] -> Integer) (_ :: t0) + where ($!) :: forall a b. (a -> b) -> a -> b diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 344b4394a9..ce0c3a97a1 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -689,6 +689,7 @@ test('UnliftedNewtypesForall', normal, compile, ['']) test('UnlifNewUnify', normal, compile, ['']) test('UnliftedNewtypesLPFamily', normal, compile, ['']) test('UnliftedNewtypesDifficultUnification', normal, compile, ['']) +test('LevPolyResult', normal, compile, ['']) test('T16832', normal, ghci_script, ['T16832.script']) test('T16995', normal, compile, ['']) test('T17007', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr b/testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr index ffc02228f2..3cc66588f0 100644 --- a/testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr +++ b/testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr @@ -36,12 +36,12 @@ constraint_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] where const :: forall a b. a -> b -> a ($) (_ :: [a] -> a) where ($) :: forall a b. (a -> b) -> a -> b - ($!) (_ :: [a] -> a) - where ($!) :: forall a b. (a -> b) -> a -> b return (_ :: a) where return :: forall (m :: * -> *) a. Monad m => a -> m a pure (_ :: a) where pure :: forall (f :: * -> *) a. Applicative f => a -> f a + ($!) (_ :: [a] -> a) + where ($!) :: forall a b. (a -> b) -> a -> b id (_ :: [a] -> a) where id :: forall a. a -> a head (_ :: [[a] -> a]) diff --git a/testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr b/testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr index 9ed1615215..5941b587bf 100644 --- a/testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr +++ b/testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr @@ -67,12 +67,7 @@ refinement_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] (and originally defined in ‘GHC.Base’)) ($) (_ :: [Integer] -> Integer) where ($) :: forall a b. (a -> b) -> a -> b - with ($) @'GHC.Types.LiftedRep @[Integer] @Integer - (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 - (and originally defined in ‘GHC.Base’)) - ($!) (_ :: [Integer] -> Integer) - where ($!) :: forall a b. (a -> b) -> a -> b - with ($!) @'GHC.Types.LiftedRep @[Integer] @Integer + with ($) @GHC.Types.LiftedRep @[Integer] @Integer (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 (and originally defined in ‘GHC.Base’)) return (_ :: Integer) @@ -85,6 +80,11 @@ refinement_hole_fits.hs:4:5: warning: [-Wtyped-holes (in -Wdefault)] with pure @((->) [Integer]) @Integer (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 (and originally defined in ‘GHC.Base’)) + ($!) (_ :: [Integer] -> Integer) + where ($!) :: forall a b. (a -> b) -> a -> b + with ($!) @GHC.Types.LiftedRep @[Integer] @Integer + (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 + (and originally defined in ‘GHC.Base’)) id (_ :: [Integer] -> Integer) where id :: forall a. a -> a with id @([Integer] -> Integer) @@ -162,12 +162,7 @@ refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] (and originally defined in ‘GHC.Base’)) ($) (_ :: Integer -> [Integer] -> Integer) where ($) :: forall a b. (a -> b) -> a -> b - with ($) @'GHC.Types.LiftedRep @Integer @([Integer] -> Integer) - (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 - (and originally defined in ‘GHC.Base’)) - ($!) (_ :: Integer -> [Integer] -> Integer) - where ($!) :: forall a b. (a -> b) -> a -> b - with ($!) @'GHC.Types.LiftedRep @Integer @([Integer] -> Integer) + with ($) @GHC.Types.LiftedRep @Integer @([Integer] -> Integer) (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 (and originally defined in ‘GHC.Base’)) return (_ :: [Integer] -> Integer) @@ -180,6 +175,11 @@ refinement_hole_fits.hs:7:5: warning: [-Wtyped-holes (in -Wdefault)] with pure @((->) Integer) @([Integer] -> Integer) (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 (and originally defined in ‘GHC.Base’)) + ($!) (_ :: Integer -> [Integer] -> Integer) + where ($!) :: forall a b. (a -> b) -> a -> b + with ($!) @GHC.Types.LiftedRep @Integer @([Integer] -> Integer) + (imported from ‘Prelude’ at refinement_hole_fits.hs:1:8-30 + (and originally defined in ‘GHC.Base’)) id (_ :: Integer -> [Integer] -> Integer) where id :: forall a. a -> a with id @(Integer -> [Integer] -> Integer) diff --git a/testsuite/tests/typecheck/should_fail/LevPolyLet.hs b/testsuite/tests/typecheck/should_fail/LevPolyLet.hs new file mode 100644 index 0000000000..6fb47133ae --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/LevPolyLet.hs @@ -0,0 +1,19 @@ +{-# language DataKinds #-} +{-# language KindSignatures #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} + +module LevPolyLet + ( example + ) where + +import GHC.Exts + +-- This should be rejected because of the let binding. +example :: forall (v :: Levity) (a :: TYPE ('BoxedRep v)). + (Int -> a) + -> (a -> Bool) + -> Bool +example f g = + let x = f 42 + in g x diff --git a/testsuite/tests/typecheck/should_fail/LevPolyLet.stderr b/testsuite/tests/typecheck/should_fail/LevPolyLet.stderr new file mode 100644 index 0000000000..8d01f4028b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/LevPolyLet.stderr @@ -0,0 +1,5 @@ +LevPolyLet.hs:18:7: + A levity-polymorphic type is not allowed here: + Type: a + Kind: TYPE ('BoxedRep v) + In the type of binder ‘x’ diff --git a/testsuite/tests/typecheck/should_fail/T12373.stderr b/testsuite/tests/typecheck/should_fail/T12373.stderr index 20137fbdad..f822b72d20 100644 --- a/testsuite/tests/typecheck/should_fail/T12373.stderr +++ b/testsuite/tests/typecheck/should_fail/T12373.stderr @@ -3,7 +3,7 @@ T12373.hs:10:19: error: • Couldn't match a lifted type with an unlifted type When matching types a0 :: * - MVar# RealWorld a1 :: TYPE 'UnliftedRep + MVar# RealWorld a1 :: TYPE ('BoxedRep 'Unlifted) Expected: (# State# RealWorld, a0 #) Actual: (# State# RealWorld, MVar# RealWorld a1 #) • In the expression: newMVar# rw diff --git a/testsuite/tests/typecheck/should_fail/T13610.stderr b/testsuite/tests/typecheck/should_fail/T13610.stderr index c04687988c..155fee8d24 100644 --- a/testsuite/tests/typecheck/should_fail/T13610.stderr +++ b/testsuite/tests/typecheck/should_fail/T13610.stderr @@ -3,7 +3,7 @@ T13610.hs:11:15: error: • Couldn't match a lifted type with an unlifted type When matching types a :: * - Weak# () :: TYPE 'UnliftedRep + Weak# () :: TYPE ('BoxedRep 'Unlifted) Expected: (# State# RealWorld, a #) Actual: (# State# RealWorld, Weak# () #) • In the expression: mkWeakNoFinalizer# double () s diff --git a/testsuite/tests/typecheck/should_fail/T14884.stderr b/testsuite/tests/typecheck/should_fail/T14884.stderr index c901811f6f..2f63301359 100644 --- a/testsuite/tests/typecheck/should_fail/T14884.stderr +++ b/testsuite/tests/typecheck/should_fail/T14884.stderr @@ -19,11 +19,11 @@ T14884.hs:4:5: error: (imported from ‘Prelude’ at T14884.hs:1:8-13 (and originally defined in ‘Data.Foldable’)) ($) :: forall a b. (a -> b) -> a -> b - with ($) @'GHC.Types.LiftedRep @String @(IO ()) + with ($) @GHC.Types.LiftedRep @String @(IO ()) (imported from ‘Prelude’ at T14884.hs:1:8-13 (and originally defined in ‘GHC.Base’)) ($!) :: forall a b. (a -> b) -> a -> b - with ($!) @'GHC.Types.LiftedRep @String @(IO ()) + with ($!) @GHC.Types.LiftedRep @String @(IO ()) (imported from ‘Prelude’ at T14884.hs:1:8-13 (and originally defined in ‘GHC.Base’)) id :: forall a. a -> a diff --git a/testsuite/tests/typecheck/should_fail/T15067.stderr b/testsuite/tests/typecheck/should_fail/T15067.stderr index 4ed3d3bc0a..a2ecc4326c 100644 --- a/testsuite/tests/typecheck/should_fail/T15067.stderr +++ b/testsuite/tests/typecheck/should_fail/T15067.stderr @@ -1,13 +1,13 @@ T15067.hs:9:14: error: - • No instance for (Typeable (# 'GHC.Types.LiftedRep #)) + • No instance for (Typeable (# GHC.Types.LiftedRep #)) arising from a use of ‘typeRep’ GHC can't yet do polykinded - Typeable ((# 'GHC.Types.LiftedRep #) :: * - -> * - -> TYPE - ('GHC.Types.SumRep - '[ 'GHC.Types.LiftedRep, - 'GHC.Types.LiftedRep])) + Typeable ((# GHC.Types.LiftedRep #) :: * + -> * + -> TYPE + ('GHC.Types.SumRep + '[GHC.Types.LiftedRep, + GHC.Types.LiftedRep])) • In the expression: typeRep In an equation for ‘floopadoop’: floopadoop = typeRep diff --git a/testsuite/tests/typecheck/should_fail/T15883b.hs b/testsuite/tests/typecheck/should_fail/T15883b.hs index 82613943a7..45b7d65360 100644 --- a/testsuite/tests/typecheck/should_fail/T15883b.hs +++ b/testsuite/tests/typecheck/should_fail/T15883b.hs @@ -11,4 +11,4 @@ module T15883b where import GHC.Exts newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) -deriving stock instance Eq (Foo LiftedRep) +deriving stock instance Eq (Foo (BoxedRep Lifted)) diff --git a/testsuite/tests/typecheck/should_fail/T15883b.stderr b/testsuite/tests/typecheck/should_fail/T15883b.stderr index a89403d4af..21b9305315 100644 --- a/testsuite/tests/typecheck/should_fail/T15883b.stderr +++ b/testsuite/tests/typecheck/should_fail/T15883b.stderr @@ -1,5 +1,6 @@ T15883b.hs:14:1: Can't make a derived instance of - ‘Eq (Foo 'LiftedRep)’ with the stock strategy: + ‘Eq (Foo ('BoxedRep 'Lifted))’ with the stock strategy: Don't know how to derive ‘Eq’ for type ‘forall a. a’ - In the stand-alone deriving instance for ‘Eq (Foo LiftedRep)’ + In the stand-alone deriving instance for + ‘Eq (Foo (BoxedRep Lifted))’ diff --git a/testsuite/tests/typecheck/should_fail/T15883c.hs b/testsuite/tests/typecheck/should_fail/T15883c.hs index bd031540c2..93d57b784b 100644 --- a/testsuite/tests/typecheck/should_fail/T15883c.hs +++ b/testsuite/tests/typecheck/should_fail/T15883c.hs @@ -11,4 +11,4 @@ module T15883c where import GHC.Exts newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) -deriving stock instance Ord (Foo LiftedRep) +deriving stock instance Ord (Foo (BoxedRep Lifted)) diff --git a/testsuite/tests/typecheck/should_fail/T15883c.stderr b/testsuite/tests/typecheck/should_fail/T15883c.stderr index 5444f5d6c8..60678c4fcb 100644 --- a/testsuite/tests/typecheck/should_fail/T15883c.stderr +++ b/testsuite/tests/typecheck/should_fail/T15883c.stderr @@ -1,5 +1,6 @@ T15883c.hs:14:1: Can't make a derived instance of - ‘Ord (Foo 'LiftedRep)’ with the stock strategy: + ‘Ord (Foo ('BoxedRep 'Lifted))’ with the stock strategy: Don't know how to derive ‘Ord’ for type ‘forall a. a’ - In the stand-alone deriving instance for ‘Ord (Foo LiftedRep)’ + In the stand-alone deriving instance for + ‘Ord (Foo (BoxedRep Lifted))’ diff --git a/testsuite/tests/typecheck/should_fail/T15883d.hs b/testsuite/tests/typecheck/should_fail/T15883d.hs index fd86c5cab3..dbcd93751e 100644 --- a/testsuite/tests/typecheck/should_fail/T15883d.hs +++ b/testsuite/tests/typecheck/should_fail/T15883d.hs @@ -11,5 +11,5 @@ module T15883d where import GHC.Exts newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) -deriving stock instance Show (Foo LiftedRep) +deriving stock instance Show (Foo (BoxedRep Lifted)) diff --git a/testsuite/tests/typecheck/should_fail/T15883d.stderr b/testsuite/tests/typecheck/should_fail/T15883d.stderr index b080ff6544..162b31072e 100644 --- a/testsuite/tests/typecheck/should_fail/T15883d.stderr +++ b/testsuite/tests/typecheck/should_fail/T15883d.stderr @@ -1,5 +1,6 @@ T15883d.hs:14:1: Can't make a derived instance of - ‘Show (Foo 'LiftedRep)’ with the stock strategy: + ‘Show (Foo ('BoxedRep 'Lifted))’ with the stock strategy: Don't know how to derive ‘Show’ for type ‘forall a. a’ - In the stand-alone deriving instance for ‘Show (Foo LiftedRep)’ + In the stand-alone deriving instance for + ‘Show (Foo (BoxedRep Lifted))’ diff --git a/testsuite/tests/typecheck/should_fail/T15883e.hs b/testsuite/tests/typecheck/should_fail/T15883e.hs index bb1dcacf92..cfecdb693e 100644 --- a/testsuite/tests/typecheck/should_fail/T15883e.hs +++ b/testsuite/tests/typecheck/should_fail/T15883e.hs @@ -13,6 +13,6 @@ import GHC.Exts import Data.Data (Data) newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) -deriving stock instance Data (Foo LiftedRep) +deriving stock instance Data (Foo (BoxedRep Lifted)) diff --git a/testsuite/tests/typecheck/should_fail/T15883e.stderr b/testsuite/tests/typecheck/should_fail/T15883e.stderr index 05e07f0307..a20b3f5d43 100644 --- a/testsuite/tests/typecheck/should_fail/T15883e.stderr +++ b/testsuite/tests/typecheck/should_fail/T15883e.stderr @@ -1,5 +1,6 @@ T15883e.hs:16:1: Can't make a derived instance of - ‘Data (Foo 'LiftedRep)’ with the stock strategy: + ‘Data (Foo ('BoxedRep 'Lifted))’ with the stock strategy: Don't know how to derive ‘Data’ for type ‘forall a. a’ - In the stand-alone deriving instance for ‘Data (Foo LiftedRep)’ + In the stand-alone deriving instance for + ‘Data (Foo (BoxedRep Lifted))’ diff --git a/testsuite/tests/typecheck/should_fail/T17021.stderr b/testsuite/tests/typecheck/should_fail/T17021.stderr index 12d6d687d8..96c700c4b7 100644 --- a/testsuite/tests/typecheck/should_fail/T17021.stderr +++ b/testsuite/tests/typecheck/should_fail/T17021.stderr @@ -2,5 +2,5 @@ T17021.hs:18:5: error: A levity-polymorphic type is not allowed here: Type: Int - Kind: TYPE (Id 'LiftedRep) + Kind: TYPE (Id ('BoxedRep 'Lifted)) When trying to create a variable of type: Int diff --git a/testsuite/tests/typecheck/should_fail/T18357a.stderr b/testsuite/tests/typecheck/should_fail/T18357a.stderr index a9e87fed98..f60e09922a 100644 --- a/testsuite/tests/typecheck/should_fail/T18357a.stderr +++ b/testsuite/tests/typecheck/should_fail/T18357a.stderr @@ -1,6 +1,6 @@ T18357a.hs:9:10: error: - • Couldn't match kind ‘r’ with ‘'LiftedRep’ + • Couldn't match kind ‘r’ with ‘LiftedRep’ Expected a type, but ‘Int’ has kind ‘*’ • In the type ‘Int’ In the definition of data constructor ‘MkT’ diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 3eff08d080..cec7b3c9ef 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -440,6 +440,7 @@ test('T13068', [extra_files(['T13068.hs', 'T13068a.hs', 'T13068.hs-boot', 'T1306 test('T13075', normal, compile_fail, ['']) test('T13105', normal, compile_fail, ['']) test('LevPolyBounded', normal, compile_fail, ['']) +test('LevPolyLet', normal, compile_fail, ['']) test('T13487', normal, compile, ['']) test('T13292', normal, multimod_compile, ['T13292', '-v0 -fdefer-type-errors']) test('T13300', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail090.stderr b/testsuite/tests/typecheck/should_fail/tcfail090.stderr index efb81e8ee6..5e1995d3eb 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail090.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail090.stderr @@ -3,6 +3,6 @@ tcfail090.hs:11:9: error: • Couldn't match a lifted type with an unlifted type When matching types a0 :: * - ByteArray# :: TYPE 'UnliftedRep + ByteArray# :: TYPE ('BoxedRep 'Unlifted) • In the expression: my_undefined In an equation for ‘die’: die _ = my_undefined diff --git a/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs index d57d2e1499..82553b4ff2 100644 --- a/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs +++ b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs @@ -6,12 +6,12 @@ module Main where import GHC.Exts data G a where - MkG :: G (TupleRep [LiftedRep, IntRep]) + MkG :: G (TupleRep [BoxedRep Lifted, IntRep]) -- tests that we don't eta-expand functions that are levity-polymorphic -- see CoreArity.mkEtaWW foo :: forall a (b :: TYPE a). G a -> b -> b -foo MkG = (\x -> x) :: forall (c :: TYPE (TupleRep [LiftedRep, IntRep])). c -> c +foo MkG = (\x -> x) :: forall (c :: TYPE (TupleRep [BoxedRep Lifted, IntRep])). c -> c data H a where MkH :: H IntRep diff --git a/testsuite/tests/typecheck/should_run/LevPolyResultInst.hs b/testsuite/tests/typecheck/should_run/LevPolyResultInst.hs new file mode 100644 index 0000000000..8302a43693 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/LevPolyResultInst.hs @@ -0,0 +1,27 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language UnboxedTuples #-} + +import GHC.Exts + +main :: IO () +main = do + print (example (\x -> I# x > 7)) + case indexArray# (example replicateFalse) 0# of + (# r #) -> print r + +-- Combines base:runST, primitive:newArray, and primitive:unsafeFreezeArray +replicateFalse :: Int# -> Array# Bool +replicateFalse n = + let !(# _, r #) = runRW# + (\s -> case newArray# n False s of + (# s', arr #) -> unsafeFreezeArray# arr s' + ) + in r + +example :: forall (v :: Levity) (a :: TYPE ('BoxedRep v)). (Int# -> a) -> a +{-# noinline example #-} +example f = f 8# diff --git a/testsuite/tests/typecheck/should_run/LevPolyResultInst.stdout b/testsuite/tests/typecheck/should_run/LevPolyResultInst.stdout new file mode 100644 index 0000000000..1cc8b5e10d --- /dev/null +++ b/testsuite/tests/typecheck/should_run/LevPolyResultInst.stdout @@ -0,0 +1,2 @@ +True +False diff --git a/testsuite/tests/typecheck/should_run/T12809.hs b/testsuite/tests/typecheck/should_run/T12809.hs index 66031a5af7..3e20403add 100644 --- a/testsuite/tests/typecheck/should_run/T12809.hs +++ b/testsuite/tests/typecheck/should_run/T12809.hs @@ -32,7 +32,7 @@ g (# b, x #) = show b ++ " " ++ show (I# x) h :: (# Double, Int# #) -> String h (# d, x #) = show d ++ " " ++ show (I# x) -cond :: forall (a :: TYPE (TupleRep [LiftedRep, IntRep])). Bool -> a -> a -> a +cond :: forall (a :: TYPE (TupleRep [BoxedRep Lifted, IntRep])). Bool -> a -> a -> a cond True x _ = x cond False _ x = x diff --git a/testsuite/tests/typecheck/should_run/T14236.stdout b/testsuite/tests/typecheck/should_run/T14236.stdout index ffa0e65dc9..73c98017f2 100644 --- a/testsuite/tests/typecheck/should_run/T14236.stdout +++ b/testsuite/tests/typecheck/should_run/T14236.stdout @@ -1,3 +1,3 @@ -(FUN 'Many 'LiftedRep 'LiftedRep Int,Char) -(FUN 'Many 'IntRep 'LiftedRep Int#,Char) +(FUN 'Many ('BoxedRep 'Lifted) ('BoxedRep 'Lifted) Int,Char) +(FUN 'Many 'IntRep ('BoxedRep 'Lifted) Int#,Char) Int# -> [Char] diff --git a/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout b/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout index 1303db844c..6ef72dfb83 100644 --- a/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout +++ b/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout @@ -5,7 +5,7 @@ good: Maybe good: TYPE good: RuntimeRep good: 'IntRep -good: FUN 'Many 'LiftedRep 'LiftedRep +good: FUN 'Many ('BoxedRep 'Lifted) ('BoxedRep 'Lifted) good: Proxy * Int good: Proxy (TYPE 'IntRep) Int# good: * diff --git a/testsuite/tests/typecheck/should_run/TypeOf.hs b/testsuite/tests/typecheck/should_run/TypeOf.hs index cec6833b64..8bd8471bdf 100644 --- a/testsuite/tests/typecheck/should_run/TypeOf.hs +++ b/testsuite/tests/typecheck/should_run/TypeOf.hs @@ -28,9 +28,9 @@ main = do print $ typeOf (Proxy :: Proxy [1,2,3]) print $ typeOf (Proxy :: Proxy 'EQ) print $ typeOf (Proxy :: Proxy TYPE) - print $ typeOf (Proxy :: Proxy (TYPE 'LiftedRep)) + print $ typeOf (Proxy :: Proxy (TYPE ('BoxedRep 'Lifted))) print $ typeOf (Proxy :: Proxy *) print $ typeOf (Proxy :: Proxy ★) - print $ typeOf (Proxy :: Proxy 'LiftedRep) + print $ typeOf (Proxy :: Proxy ('BoxedRep 'Lifted)) print $ typeOf (Proxy :: Proxy '(1, "hello")) print $ typeOf (Proxy :: Proxy (~~)) diff --git a/testsuite/tests/typecheck/should_run/TypeOf.stdout b/testsuite/tests/typecheck/should_run/TypeOf.stdout index 40d2cb5f8f..3cb5e49036 100644 --- a/testsuite/tests/typecheck/should_run/TypeOf.stdout +++ b/testsuite/tests/typecheck/should_run/TypeOf.stdout @@ -19,6 +19,6 @@ Proxy (RuntimeRep -> *) TYPE Proxy * * Proxy * * Proxy * * -Proxy RuntimeRep 'LiftedRep +Proxy RuntimeRep ('BoxedRep 'Lifted) Proxy (Natural,Symbol) ('(,) Natural Symbol 1 "hello") Proxy (* -> * -> Constraint) ((~~) * *) diff --git a/testsuite/tests/typecheck/should_run/TypeRep.hs b/testsuite/tests/typecheck/should_run/TypeRep.hs index beae93f6b3..886479fd33 100644 --- a/testsuite/tests/typecheck/should_run/TypeRep.hs +++ b/testsuite/tests/typecheck/should_run/TypeRep.hs @@ -53,10 +53,10 @@ main = do print $ rep @(Proxy [1,2,3]) print $ rep @(Proxy 'EQ) print $ rep @(Proxy TYPE) - print $ rep @(Proxy (TYPE 'LiftedRep)) + print $ rep @(Proxy (TYPE ('BoxedRep 'Lifted))) print $ rep @(Proxy *) print $ rep @(Proxy ★) - print $ rep @(Proxy 'LiftedRep) + print $ rep @(Proxy ('BoxedRep 'Lifted)) -- Something lifted and primitive print $ rep @RealWorld -- #12132 diff --git a/testsuite/tests/typecheck/should_run/TypeRep.stdout b/testsuite/tests/typecheck/should_run/TypeRep.stdout index a0c03e09d8..cf43264714 100644 --- a/testsuite/tests/typecheck/should_run/TypeRep.stdout +++ b/testsuite/tests/typecheck/should_run/TypeRep.stdout @@ -13,7 +13,7 @@ Int -> Int (%,%) (Eq Int) (Eq [Char]) Int# (##) -(#,#) 'IntRep 'LiftedRep Int# Int +(#,#) 'IntRep ('BoxedRep 'Lifted) Int# Int Proxy Constraint (Eq Int) Proxy * (Int,Int) Proxy Symbol "hello world" @@ -24,5 +24,5 @@ Proxy (RuntimeRep -> *) TYPE Proxy * * Proxy * * Proxy * * -Proxy RuntimeRep 'LiftedRep +Proxy RuntimeRep ('BoxedRep 'Lifted) RealWorld diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index ef8ae9136d..ef7bedb354 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/testsuite/tests/typecheck/should_run/all.T @@ -145,5 +145,6 @@ test('UnliftedNewtypesFamilyRun', normal, compile_and_run, ['']) test('UnliftedNewtypesDependentFamilyRun', normal, compile_and_run, ['']) test('UnliftedNewtypesIdentityRun', normal, compile_and_run, ['']) test('UnliftedNewtypesCoerceRun', normal, compile_and_run, ['']) +test('LevPolyResultInst', normal, compile_and_run, ['']) test('T17104', normal, compile_and_run, ['']) test('T18627', normal, compile_and_run, ['-O']) # Optimisation shows up the bug diff --git a/testsuite/tests/unboxedsums/T12711.stdout b/testsuite/tests/unboxedsums/T12711.stdout index 54af3fdfa6..18a67a078d 100644 --- a/testsuite/tests/unboxedsums/T12711.stdout +++ b/testsuite/tests/unboxedsums/T12711.stdout @@ -1,2 +1,4 @@ (# _ | _ #) :: TYPE - ('GHC.Types.SumRep '[ 'GHC.Types.LiftedRep, 'GHC.Types.LiftedRep]) + ('GHC.Types.SumRep + '[ 'GHC.Types.BoxedRep 'GHC.Types.Lifted, + 'GHC.Types.BoxedRep 'GHC.Types.Lifted]) diff --git a/testsuite/tests/unboxedsums/sum_rr.hs b/testsuite/tests/unboxedsums/sum_rr.hs index 448a9b2221..11c8cbb648 100644 --- a/testsuite/tests/unboxedsums/sum_rr.hs +++ b/testsuite/tests/unboxedsums/sum_rr.hs @@ -5,4 +5,4 @@ module Example where import Data.Typeable import GHC.Exts -data Wat (a :: TYPE (SumRep '[LiftedRep, IntRep])) = Wat a +data Wat (a :: TYPE (SumRep '[BoxedRep Lifted, IntRep])) = Wat a diff --git a/utils/haddock b/utils/haddock -Subproject 48c4982646b7fe6343ccdf1581c97a7735fe894 +Subproject 4ffb30d8b637ccebecc81ce610f0af451ac8088 |