ghc-lib-parser 0.20221101 → 0.20221201

raw patch · 191 files changed

+13239/−8318 lines, 191 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• compiler/CodeGen.Platform.h +2/−1
• compiler/GHC/Builtin/Names.hs +66/−33
• compiler/GHC/Builtin/PrimOps.hs +15/−2
• compiler/GHC/Builtin/Types.hs +440/−280
• compiler/GHC/Builtin/Types.hs-boot +1/−1
• compiler/GHC/Builtin/Types/Prim.hs +407/−156
• compiler/GHC/Builtin/Types/Prim.hs-boot +0/−5
• compiler/GHC/Builtin/Uniques.hs +59/−15
• compiler/GHC/ByteCode/Types.hs +2/−1
• compiler/GHC/Cmm.hs +4/−4
• compiler/GHC/Cmm/BlockId.hs +2/−1
• compiler/GHC/Cmm/CLabel.hs +54/−39
• compiler/GHC/Cmm/CLabel.hs-boot +1/−1
• compiler/GHC/Cmm/Expr.hs +0/−1
• compiler/GHC/Cmm/MachOp.hs +0/−4
• compiler/GHC/Cmm/Node.hs +2/−4
• compiler/GHC/Cmm/Reg.hs +4/−1
• compiler/GHC/Core.hs +21/−55
• compiler/GHC/Core/Coercion.hs +345/−329
• compiler/GHC/Core/Coercion.hs-boot +4/−2
• compiler/GHC/Core/Coercion/Opt.hs +89/−71
• compiler/GHC/Core/ConLike.hs +6/−2
• compiler/GHC/Core/DataCon.hs +309/−109
• compiler/GHC/Core/DataCon.hs-boot +1/−0
• compiler/GHC/Core/FVs.hs +25/−14
• compiler/GHC/Core/FamInstEnv.hs +8/−5
• compiler/GHC/Core/InstEnv.hs +6/−3
• compiler/GHC/Core/Lint.hs +182/−87
• compiler/GHC/Core/Make.hs +277/−128
• compiler/GHC/Core/Map/Expr.hs +2/−6
• compiler/GHC/Core/Map/Type.hs +24/−60
• compiler/GHC/Core/Multiplicity.hs +97/−36
• compiler/GHC/Core/Opt/Arity.hs +25/−26
• compiler/GHC/Core/Opt/ConstantFold.hs +26/−33
• compiler/GHC/Core/Opt/Monad.hs +23/−25
• compiler/GHC/Core/Opt/OccurAnal.hs +0/−1
• compiler/GHC/Core/Opt/Simplify.hs +40/−36
• compiler/GHC/Core/Opt/Simplify/Env.hs +2/−3
• compiler/GHC/Core/Opt/Simplify/Iteration.hs +40/−15
• compiler/GHC/Core/Opt/Simplify/Monad.hs +3/−3
• compiler/GHC/Core/Opt/Simplify/Utils.hs +183/−37
• compiler/GHC/Core/PatSyn.hs +2/−2
• compiler/GHC/Core/Reduction.hs +21/−35
• compiler/GHC/Core/RoughMap.hs +143/−48
• compiler/GHC/Core/Rules.hs +123/−33
• compiler/GHC/Core/SimpleOpt.hs +1/−1
• compiler/GHC/Core/Subst.hs +8/−6
• compiler/GHC/Core/Tidy.hs +0/−2
• compiler/GHC/Core/TyCo/Compare.hs +584/−0
• compiler/GHC/Core/TyCo/FVs.hs +332/−9
• compiler/GHC/Core/TyCo/Ppr.hs +19/−22
• compiler/GHC/Core/TyCo/Ppr.hs-boot +1/−0
• compiler/GHC/Core/TyCo/Rep.hs +281/−365
• compiler/GHC/Core/TyCo/Rep.hs-boot +16/−6
• compiler/GHC/Core/TyCo/Subst.hs +21/−12
• compiler/GHC/Core/TyCo/Tidy.hs +13/−13
• compiler/GHC/Core/TyCon.hs +190/−177
• compiler/GHC/Core/TyCon.hs-boot +0/−1
• compiler/GHC/Core/Type.hs +3305/−3937
• compiler/GHC/Core/Type.hs-boot +10/−4
• compiler/GHC/Core/Unfold.hs +5/−2
• compiler/GHC/Core/Unify.hs +97/−152
• compiler/GHC/Core/UsageEnv.hs +8/−8
• compiler/GHC/Core/Utils.hs +8/−21
• compiler/GHC/Core/Utils.hs-boot +0/−6
• compiler/GHC/CoreToIface.hs +39/−35
• compiler/GHC/CoreToIface.hs-boot +1/−1
• compiler/GHC/Data/Bool.hs +1/−1
• compiler/GHC/Data/FastMutInt.hs +1/−1
• compiler/GHC/Data/FastString.hs +20/−2
• compiler/GHC/Data/Graph/Directed.hs +19/−0
• compiler/GHC/Data/Graph/UnVar.hs +7/−7
• compiler/GHC/Data/List/Infinite.hs +194/−0
• compiler/GHC/Data/List/SetOps.hs +0/−1
• compiler/GHC/Driver/Backend.hs +183/−123
• compiler/GHC/Driver/Backend/Internal.hs +1/−0
• compiler/GHC/Driver/Config/Core/Lint.hs +8/−8
• compiler/GHC/Driver/Env.hs +0/−1
• compiler/GHC/Driver/Errors.hs +5/−5
• compiler/GHC/Driver/Errors/Ppr.hs +0/−0
• compiler/GHC/Driver/Flags.hs +3/−0
• compiler/GHC/Driver/Phases.hs +12/−3
• compiler/GHC/Driver/Pipeline/Phases.hs +1/−0
• compiler/GHC/Driver/Ppr.hs +7/−7
• compiler/GHC/Driver/Session.hs +17/−2
• compiler/GHC/Hs/Decls.hs +0/−3
• compiler/GHC/Hs/Expr.hs +12/−5
• compiler/GHC/Hs/Instances.hs +1/−5
• compiler/GHC/Hs/Type.hs +6/−6
• compiler/GHC/Hs/Utils.hs +12/−53
• compiler/GHC/HsToCore/Errors/Ppr.hs +1/−1
• compiler/GHC/HsToCore/Pmc/Ppr.hs +6/−6
• compiler/GHC/HsToCore/Pmc/Solver/Types.hs +1/−0
• compiler/GHC/Iface/Syntax.hs +64/−40
• compiler/GHC/Iface/Type.hs +226/−156
• compiler/GHC/Linker/Static/Utils.hs +14/−14
• compiler/GHC/Linker/Types.hs +2/−2
• compiler/GHC/Parser.y +6/−6
• compiler/GHC/Parser/Errors/Ppr.hs +14/−2
• compiler/GHC/Parser/Errors/Types.hs +5/−0
• compiler/GHC/Parser/Lexer.x +81/−16
• compiler/GHC/Parser/PostProcess.hs +4/−5
• compiler/GHC/Platform.hs +1/−0
• compiler/GHC/Platform/Regs.hs +6/−0
• compiler/GHC/Platform/Wasm32.hs +10/−0
• compiler/GHC/Prelude.hs +5/−55
• compiler/GHC/Prelude/Basic.hs +104/−0
• compiler/GHC/Runtime/Context.hs +5/−4
• compiler/GHC/Settings/Constants.hs +2/−2
• compiler/GHC/Stg/Syntax.hs +15/−4
• compiler/GHC/Tc/Errors/Ppr.hs +267/−65
• compiler/GHC/Tc/Errors/Types.hs +259/−3
• compiler/GHC/Tc/Solver/InertSet.hs +17/−20
• compiler/GHC/Tc/Solver/Types.hs +0/−2
• compiler/GHC/Tc/Types.hs +1/−1
• compiler/GHC/Tc/Types/Constraint.hs +36/−45
• compiler/GHC/Tc/Types/Evidence.hs +52/−127
• compiler/GHC/Tc/Types/Origin.hs +0/−3
• compiler/GHC/Tc/Utils/TcType.hs +107/−327
• compiler/GHC/Tc/Utils/TcType.hs-boot +0/−4
• compiler/GHC/Types/Basic.hs +26/−15
• compiler/GHC/Types/CostCentre.hs +33/−16
• compiler/GHC/Types/Demand.hs +61/−17
• compiler/GHC/Types/Error.hs +1/−1
• compiler/GHC/Types/Error/Codes.hs +26/−0
• compiler/GHC/Types/ForeignStubs.hs +3/−2
• compiler/GHC/Types/Id.hs +2/−3
• compiler/GHC/Types/Id/Make.hs +324/−94
• compiler/GHC/Types/Literal.hs +26/−20
• compiler/GHC/Types/Name.hs +27/−23
• compiler/GHC/Types/Name/Occurrence.hs +10/−11
• compiler/GHC/Types/Name/Occurrence.hs-boot +1/−1
• compiler/GHC/Types/Name/Ppr.hs +45/−9
• compiler/GHC/Types/RepType.hs +23/−27
• compiler/GHC/Types/TyThing.hs +11/−5
• compiler/GHC/Types/Unique.hs +3/−1
• compiler/GHC/Types/Unique/DFM.hs +6/−2
• compiler/GHC/Types/Unique/FM.hs +19/−1
• compiler/GHC/Types/Unique/Map.hs +23/−1
• compiler/GHC/Types/Var.hs +431/−98
• compiler/GHC/Types/Var.hs-boot +2/−2
• compiler/GHC/Types/Var/Env.hs +6/−2
• compiler/GHC/Unit/External.hs +1/−2
• compiler/GHC/Unit/Module/Graph.hs +5/−4
• compiler/GHC/Unit/Module/WholeCoreBindings.hs +3/−3
• compiler/GHC/Unit/Types.hs +28/−12
• compiler/GHC/Unit/Types.hs-boot +1/−1
• compiler/GHC/Utils/Binary.hs +143/−12
• compiler/GHC/Utils/BufHandle.hs +22/−1
• compiler/GHC/Utils/Constants.hs +1/−1
• compiler/GHC/Utils/Error.hs +17/−17
• compiler/GHC/Utils/Exception.hs +1/−1
• compiler/GHC/Utils/Fingerprint.hs +1/−1
• compiler/GHC/Utils/GlobalVars.hs +1/−1
• compiler/GHC/Utils/IO/Unsafe.hs +1/−1
• compiler/GHC/Utils/Json.hs +1/−1
• compiler/GHC/Utils/Lexeme.hs +9/−9
• compiler/GHC/Utils/Logger.hs +8/−7
• compiler/GHC/Utils/Misc.hs +6/−29
• compiler/GHC/Utils/Monad.hs +15/−0
• compiler/GHC/Utils/Outputable.hs +507/−145
• compiler/GHC/Utils/Panic.hs +8/−1
• compiler/GHC/Utils/Panic/Plain.hs +4/−3
• compiler/GHC/Utils/Ppr.hs +43/−10
• compiler/GHC/Utils/Ppr/Colour.hs +1/−1
• compiler/GHC/Utils/Trace.hs +12/−1
• compiler/Language/Haskell/Syntax/Decls.hs +0/−3
• compiler/Language/Haskell/Syntax/Expr.hs +0/−2
• compiler/Language/Haskell/Syntax/Type.hs +2/−0
• compiler/MachRegs.h +35/−0
• compiler/ghc-llvm-version.h +1/−1
• compiler/ghc.cabal +883/−0
• ghc-lib-parser.cabal +12/−1
• ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +2/−2
• ghc-lib/stage0/lib/settings +1/−1
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
• ghc-lib/stage0/rts/build/include/ghcautoconf.h +14/−1
• ghc/ghc-bin.cabal +98/−0
• libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs +1/−0
• libraries/ghc-boot-th/ghc-boot-th.cabal +39/−0
• libraries/ghc-boot/GHC/BaseDir.hs +2/−1
• libraries/ghc-boot/GHC/Data/ShortText.hs +9/−2
• libraries/ghc-boot/GHC/Platform/ArchOS.hs +4/−0
• libraries/ghc-boot/GHC/Utils/Encoding.hs +4/−2
• libraries/ghc-boot/ghc-boot.cabal +83/−0
• libraries/ghc-heap/ghc-heap.cabal +50/−0
• libraries/ghci/GHCi/FFI.hsc +37/−4
• libraries/ghci/GHCi/Message.hs +1/−1
• libraries/ghci/ghci.cabal +86/−0
• libraries/template-haskell/Language/Haskell/TH/Syntax.hs +4/−2
• libraries/template-haskell/template-haskell.cabal +73/−0

@@ -664,7 +664,8 @@ #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \     || defined(MACHREGS_powerpc) \     || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \-    || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64)+    || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) \+    || defined(MACHREGS_wasm32) # if defined(REG_Base) globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base) # endif

@@ -119,7 +119,6 @@ -}  {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}  module GHC.Builtin.Names    ( Unique, Uniquable(..), hasKey,  -- Re-exported for convenience@@ -143,6 +142,8 @@ import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Data.FastString+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf  import Language.Haskell.Syntax.Module.Name @@ -154,10 +155,14 @@ ************************************************************************ -} -allNameStrings :: [String]+allNameStrings :: Infinite String -- Infinite list of a,b,c...z, aa, ab, ac, ... etc-allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ]+allNameStrings = Inf.allListsOf ['a'..'z'] +allNameStringList :: [String]+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc+allNameStringList = Inf.toList allNameStrings+ {- ************************************************************************ *                                                                      *@@ -258,6 +263,7 @@         starKindRepName,         starArrStarKindRepName,         starArrStarArrStarKindRepName,+        constraintKindRepName,          -- WithDict         withDictClassName,@@ -333,6 +339,9 @@         fromListNName,         toListName, +        -- Non-empty lists+        nonEmptyTyConName,+         -- Overloaded record dot, record update         getFieldName, setFieldName, @@ -341,7 +350,7 @@         zipName, foldrName, buildName, augmentName, appendName,          -- FFI primitive types that are not wired-in.-        stablePtrTyConName, ptrTyConName, funPtrTyConName,+        stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName,         int8TyConName, int16TyConName, int32TyConName, int64TyConName,         word8TyConName, word16TyConName, word32TyConName, word64TyConName, @@ -538,7 +547,7 @@     gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,     gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,     gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT,-    gHC_LIST, gHC_TUPLE, gHC_TUPLE_PRIM, dATA_EITHER, dATA_VOID, dATA_LIST, dATA_STRING,+    gHC_LIST, gHC_TUPLE, gHC_TUPLE_PRIM, dATA_EITHER, dATA_LIST, dATA_STRING,     dATA_FOLDABLE, dATA_TRAVERSABLE,     gHC_CONC, gHC_IO, gHC_IO_Exception,     gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,@@ -548,7 +557,7 @@     aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST,     cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,     gHC_TYPENATS, gHC_TYPENATS_INTERNAL,-    dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module+    dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_TYPES :: Module  gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values gHC_PRIM_PANIC  = mkPrimModule (fsLit "GHC.Prim.Panic")@@ -574,7 +583,6 @@ gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple") gHC_TUPLE_PRIM  = mkPrimModule (fsLit "GHC.Tuple.Prim") dATA_EITHER     = mkBaseModule (fsLit "Data.Either")-dATA_VOID       = mkBaseModule (fsLit "Data.Void") dATA_LIST       = mkBaseModule (fsLit "Data.List") dATA_STRING     = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")@@ -618,6 +626,7 @@ dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce") dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace") uNSAFE_COERCE   = mkBaseModule (fsLit "Unsafe.Coerce")+fOREIGN_C_TYPES = mkBaseModule (fsLit "Foreign.C.Types")  gHC_SRCLOC :: Module gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")@@ -954,7 +963,7 @@ rightDataConName  = dcQual dATA_EITHER (fsLit "Right")  rightDataConKey  voidTyConName :: Name-voidTyConName = tcQual dATA_VOID (fsLit "Void") voidTyConKey+voidTyConName = tcQual gHC_BASE (fsLit "Void") voidTyConKey  -- Generics (types) v1TyConName, u1TyConName, par1TyConName, rec1TyConName,@@ -1401,15 +1410,20 @@ trGhcPrimModuleName   = varQual gHC_TYPES         (fsLit "tr$ModuleGHCPrim")  trGhcPrimModuleKey  -- Typeable KindReps for some common cases-starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name-starKindRepName        = varQual gHC_TYPES         (fsLit "krep$*")         starKindRepKey-starArrStarKindRepName = varQual gHC_TYPES         (fsLit "krep$*Arr*")     starArrStarKindRepKey-starArrStarArrStarKindRepName = varQual gHC_TYPES  (fsLit "krep$*->*->*")   starArrStarArrStarKindRepKey+starKindRepName, starArrStarKindRepName,+  starArrStarArrStarKindRepName, constraintKindRepName :: Name+starKindRepName        = varQual gHC_TYPES         (fsLit "krep$*")          starKindRepKey+starArrStarKindRepName = varQual gHC_TYPES         (fsLit "krep$*Arr*")      starArrStarKindRepKey+starArrStarArrStarKindRepName = varQual gHC_TYPES  (fsLit "krep$*->*->*")    starArrStarArrStarKindRepKey+constraintKindRepName  = varQual gHC_TYPES         (fsLit "krep$Constraint") constraintKindRepKey  -- WithDict withDictClassName :: Name-withDictClassName     = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey+withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey +nonEmptyTyConName :: Name+nonEmptyTyConName = tcQual gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey+ -- Custom type errors errorMessageTypeErrorFamName   , typeErrorTextDataConName@@ -1651,6 +1665,10 @@ fingerprintDataConName =     dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey +constPtrConName :: Name+constPtrConName =+    tcQual fOREIGN_C_TYPES (fsLit "ConstPtr") constPtrTyConKey+ {- ************************************************************************ *                                                                      *@@ -1783,7 +1801,7 @@  addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey,     byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey,-    doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey,+    doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey,     intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey,     int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey,     int64PrimTyConKey, int64TyConKey,@@ -1794,7 +1812,8 @@     ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,     stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey,     smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,-    stringTyConKey :: Unique+    stringTyConKey,+    ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique addrPrimTyConKey                        = mkPreludeTyConUnique  1 arrayPrimTyConKey                       = mkPreludeTyConUnique  3 boolTyConKey                            = mkPreludeTyConUnique  4@@ -1806,7 +1825,7 @@ doubleTyConKey                          = mkPreludeTyConUnique 10 floatPrimTyConKey                       = mkPreludeTyConUnique 11 floatTyConKey                           = mkPreludeTyConUnique 12-funTyConKey                             = mkPreludeTyConUnique 13+fUNTyConKey                             = mkPreludeTyConUnique 13 intPrimTyConKey                         = mkPreludeTyConUnique 14 intTyConKey                             = mkPreludeTyConUnique 15 int8PrimTyConKey                        = mkPreludeTyConUnique 16@@ -1837,6 +1856,10 @@ eqTyConKey                              = mkPreludeTyConUnique 40 heqTyConKey                             = mkPreludeTyConUnique 41 +ctArrowTyConKey                       = mkPreludeTyConUnique 42+ccArrowTyConKey                       = mkPreludeTyConUnique 43+tcArrowTyConKey                       = mkPreludeTyConUnique 44+ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,     mutVarPrimTyConKey, ioTyConKey,     wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey,@@ -1847,7 +1870,7 @@     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,     eqReprPrimTyConKey, eqPhantPrimTyConKey,     compactPrimTyConKey, stackSnapshotPrimTyConKey,-    promptTagPrimTyConKey :: Unique+    promptTagPrimTyConKey, constPtrTyConKey :: Unique statePrimTyConKey                       = mkPreludeTyConUnique 50 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51 stableNameTyConKey                      = mkPreludeTyConUnique 52@@ -1887,16 +1910,21 @@ nonEmptyTyConKey :: Unique nonEmptyTyConKey                        = mkPreludeTyConUnique 86 +dictTyConKey :: Unique+dictTyConKey                            = mkPreludeTyConUnique 87+ -- Kind constructors liftedTypeKindTyConKey, unliftedTypeKindTyConKey,-  tYPETyConKey, liftedRepTyConKey, unliftedRepTyConKey,+  tYPETyConKey, cONSTRAINTTyConKey,+  liftedRepTyConKey, unliftedRepTyConKey,   constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey,   vecCountTyConKey, vecElemTyConKey,   zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique liftedTypeKindTyConKey                  = mkPreludeTyConUnique 88 unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89-tYPETyConKey                            = mkPreludeTyConUnique 90-constraintKindTyConKey                  = mkPreludeTyConUnique 92+tYPETyConKey                            = mkPreludeTyConUnique 91+cONSTRAINTTyConKey                      = mkPreludeTyConUnique 92+constraintKindTyConKey                  = mkPreludeTyConUnique 93 levityTyConKey                          = mkPreludeTyConUnique 94 runtimeRepTyConKey                      = mkPreludeTyConUnique 95 vecCountTyConKey                        = mkPreludeTyConUnique 96@@ -1918,7 +1946,6 @@ kindRepTyConKey                         = mkPreludeTyConUnique 107 typeLitSortTyConKey                     = mkPreludeTyConUnique 108 - -- Generics (Unique keys) v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,   k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,@@ -2054,6 +2081,7 @@ typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414 typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415 typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416+constPtrTyConKey = mkPreludeTyConUnique 417  {- ************************************************************************@@ -2067,8 +2095,7 @@     floatDataConKey, intDataConKey, nilDataConKey,     ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,     word8DataConKey, ioDataConKey, heqDataConKey,-    coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey,-    nonEmptyDataConKey :: Unique+    eqDataConKey, nothingDataConKey, justDataConKey :: Unique  charDataConKey                          = mkPreludeDataConUnique  1 consDataConKey                          = mkPreludeDataConUnique  2@@ -2087,7 +2114,6 @@ wordDataConKey                          = mkPreludeDataConUnique 15 ioDataConKey                            = mkPreludeDataConUnique 16 heqDataConKey                           = mkPreludeDataConUnique 18-nonEmptyDataConKey                      = mkPreludeDataConUnique 19  -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique@@ -2105,7 +2131,10 @@ ordEQDataConKey                         = mkPreludeDataConUnique 28 ordGTDataConKey                         = mkPreludeDataConUnique 29 +mkDictDataConKey :: Unique+mkDictDataConKey                        = mkPreludeDataConUnique 30 +coercibleDataConKey :: Unique coercibleDataConKey                     = mkPreludeDataConUnique 32  staticPtrDataConKey :: Unique@@ -2249,7 +2278,7 @@ ************************************************************************ -} -wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,+wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey,     buildIdKey, foldrIdKey, recSelErrorIdKey,     seqIdKey, eqStringIdKey,     noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,@@ -2266,6 +2295,7 @@ augmentIdKey                  = mkPreludeMiscIdUnique  2 appendIdKey                   = mkPreludeMiscIdUnique  3 buildIdKey                    = mkPreludeMiscIdUnique  4+absentConstraintErrorIdKey    = mkPreludeMiscIdUnique  5 foldrIdKey                    = mkPreludeMiscIdUnique  6 recSelErrorIdKey              = mkPreludeMiscIdUnique  7 seqIdKey                      = mkPreludeMiscIdUnique  8@@ -2330,7 +2360,7 @@ nospecIdKey :: Unique nospecIdKey                   = mkPreludeMiscIdUnique 109 -inlineIdKey, noinlineIdKey :: Unique+inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique inlineIdKey                   = mkPreludeMiscIdUnique 120 -- see below @@ -2338,8 +2368,9 @@ mapIdKey                = mkPreludeMiscIdUnique 121 dollarIdKey             = mkPreludeMiscIdUnique 123 coercionTokenIdKey      = mkPreludeMiscIdUnique 124-noinlineIdKey           = mkPreludeMiscIdUnique 125-considerAccessibleIdKey = mkPreludeMiscIdUnique 126+considerAccessibleIdKey = mkPreludeMiscIdUnique 125+noinlineIdKey           = mkPreludeMiscIdUnique 126+noinlineConstraintIdKey = mkPreludeMiscIdUnique 127  integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique integerToFloatIdKey    = mkPreludeMiscIdUnique 128@@ -2479,14 +2510,15 @@ trLiftedRepKey         = mkPreludeMiscIdUnique 516  -- KindReps for common cases-starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique-starKindRepKey        = mkPreludeMiscIdUnique 520-starArrStarKindRepKey = mkPreludeMiscIdUnique 521+starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique+starKindRepKey               = mkPreludeMiscIdUnique 520+starArrStarKindRepKey        = mkPreludeMiscIdUnique 521 starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522+constraintKindRepKey         = mkPreludeMiscIdUnique 523  -- Dynamic toDynIdKey :: Unique-toDynIdKey            = mkPreludeMiscIdUnique 523+toDynIdKey            = mkPreludeMiscIdUnique 530   bitIntegerIdKey :: Unique@@ -2780,9 +2812,10 @@     [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey     , liftedDataConKey, unliftedDataConKey     , tYPETyConKey+    , cONSTRAINTTyConKey     , runtimeRepTyConKey, boxedRepDataConKey     , eqTyConKey     , listTyConKey     , oneDataConKey     , manyDataConKey-    , funTyConKey ]+    , fUNTyConKey, unrestrictedFunTyConKey ]

@@ -5,19 +5,21 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}  module GHC.Builtin.PrimOps (         PrimOp(..), PrimOpVecCat(..), allThePrimOps,         primOpType, primOpSig, primOpResultType,         primOpTag, maxPrimOpTag, primOpOcc,         primOpWrapperId,+        pprPrimOp,          tagToEnumKey,          primOpOutOfLine, primOpCodeSize,         primOpOkForSpeculation, primOpOkForSideEffects,         primOpIsCheap, primOpFixity, primOpDocs,-        primOpIsDiv,+        primOpIsDiv, primOpIsReallyInline,          getPrimOpResultInfo,  isComparisonPrimOp, PrimOpResultInfo(..), @@ -788,8 +790,10 @@  -- Output stuff: -pprPrimOp  :: PrimOp -> SDoc+pprPrimOp  :: IsLine doc => PrimOp -> doc pprPrimOp other_op = pprOccName (primOpOcc other_op)+{-# SPECIALIZE pprPrimOp :: PrimOp -> SDoc #-}+{-# SPECIALIZE pprPrimOp :: PrimOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  {- ************************************************************************@@ -804,3 +808,12 @@ instance Outputable PrimCall where   ppr (PrimCall lbl pkgId)         = text "__primcall" <+> ppr pkgId <+> ppr lbl++-- | Indicate if a primop is really inline: that is, it isn't out-of-line and it+-- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument+-- hence induce thread/stack/heap changes.+primOpIsReallyInline :: PrimOp -> Bool+primOpIsReallyInline = \case+  SeqOp       -> False+  DataToTagOp -> False+  p           -> not (primOpOutOfLine p)

@@ -34,7 +34,7 @@         promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,          -- * Boxing primitive types-        boxingDataCon_maybe,+        boxingDataCon, BoxingInfo(..),          -- * Char         charTyCon, charDataCon, charTyCon_RDR,@@ -63,10 +63,6 @@         promotedNilDataCon, promotedConsDataCon,         mkListTy, mkPromotedListTy, -        -- * NonEmpty-        nonEmptyTyCon, nonEmptyTyConName,-        nonEmptyDataCon, nonEmptyDataConName,-         -- * Maybe         maybeTyCon, maybeTyConName,         nothingDataCon, nothingDataConName, promotedNothingDataCon,@@ -83,7 +79,7 @@         unboxedUnitTy,         unboxedUnitTyCon, unboxedUnitDataCon,         unboxedTupleKind, unboxedSumKind,-        filterCTuple,+        filterCTuple, mkConstraintTupleTy,          -- ** Constraint tuples         cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,@@ -105,6 +101,8 @@         isLiftedTypeKindTyConName,         typeToTypeKind,         liftedRepTyCon, unliftedRepTyCon,+        tYPETyCon, tYPETyConName, tYPEKind,+        cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind,         constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind,         constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon,         constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName,@@ -116,15 +114,17 @@         coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,          -- * RuntimeRep and friends-        runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon,+        runtimeRepTyCon, vecCountTyCon, vecElemTyCon,          boxedRepDataConTyCon,-        runtimeRepTy, levityTy, liftedRepTy, unliftedRepTy, zeroBitRepTy,+        runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy,          vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, +        -- * Levity+        levityTyCon, levityTy,         liftedDataConTyCon, unliftedDataConTyCon,-        liftedDataConTy, unliftedDataConTy,+        liftedDataConTy,    unliftedDataConTy,          intRepDataConTy,         int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,@@ -170,27 +170,32 @@ import GHC.Builtin.Uniques  -- others:+import GHC.Core( Expr(Type), mkConApp ) import GHC.Core.Coercion.Axiom-import GHC.Types.Id-import GHC.Types.TyThing-import GHC.Types.SourceText-import GHC.Types.Var (VarBndr (Bndr))-import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )-import GHC.Unit.Module        ( Module ) import GHC.Core.Type-import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))-import GHC.Core.TyCo.Rep (RuntimeRepType)-import GHC.Types.RepType+import GHC.Types.Id import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon import GHC.Core.Class     ( Class, mkClass )+import GHC.Core.Map.Type  ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap )+import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))++import GHC.Types.TyThing+import GHC.Types.SourceText+import GHC.Types.Var ( VarBndr (Bndr) )+import GHC.Types.RepType import GHC.Types.Name.Reader import GHC.Types.Name as Name-import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )+import GHC.Types.Name.Env ( lookupNameEnv_NF ) import GHC.Types.Basic import GHC.Types.ForeignCall import GHC.Types.Unique.Set+++import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )+import GHC.Unit.Module        ( Module )+ import Data.Array import GHC.Data.FastString import GHC.Data.BooleanFormula ( mkAnd )@@ -202,6 +207,7 @@  import qualified Data.ByteString.Char8 as BS +import Data.Foldable import Data.List        ( elemIndex, intersperse )  alpha_tyvar :: [TyVar]@@ -274,7 +280,8 @@ -- See also Note [Known-key names] wiredInTyCons :: [TyCon] -wiredInTyCons = [ -- Units are not treated like other tuples, because they+wiredInTyCons = map (dataConTyCon . snd) boxingDataCons+             ++ [ -- Units are not treated like other tuples, because they                   -- are defined in GHC.Base, and there's only a few of them. We                   -- put them in wiredInTyCons so that they will pre-populate                   -- the name cache, so the parser in isBuiltInOcc_maybe doesn't@@ -318,7 +325,6 @@                 , unliftedRepTyCon                 , zeroBitRepTyCon                 , zeroBitTypeTyCon-                , nonEmptyTyCon                 ]  mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name@@ -377,10 +383,6 @@ nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon -nonEmptyTyConName, nonEmptyDataConName :: Name-nonEmptyTyConName   = mkWiredInTyConName   UserSyntax  gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey nonEmptyTyCon-nonEmptyDataConName = mkWiredInDataConName UserSyntax  gHC_BASE (fsLit ":|") nonEmptyDataConKey nonEmptyDataCon- maybeTyConName, nothingDataConName, justDataConName :: Name maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_MAYBE (fsLit "Maybe")                                           maybeTyConKey maybeTyCon@@ -509,81 +511,7 @@ typeSymbolKindConName :: Name typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon -constraintKindTyConName :: Name-constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey   constraintKindTyCon -liftedTypeKindTyConName, unliftedTypeKindTyConName, zeroBitTypeTyConName :: Name-liftedTypeKindTyConName   = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")         liftedTypeKindTyConKey   liftedTypeKindTyCon-unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") unliftedTypeKindTyConKey unliftedTypeKindTyCon-zeroBitTypeTyConName      = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType")  zeroBitTypeTyConKey      zeroBitTypeTyCon--liftedRepTyConName, unliftedRepTyConName, zeroBitRepTyConName :: Name-liftedRepTyConName   = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep")   liftedRepTyConKey   liftedRepTyCon-unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") unliftedRepTyConKey unliftedRepTyCon-zeroBitRepTyConName  = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep")  zeroBitRepTyConKey  zeroBitRepTyCon--multiplicityTyConName :: Name-multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")-                          multiplicityTyConKey multiplicityTyCon--oneDataConName, manyDataConName :: Name-oneDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon-manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon--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 "IntRep"-      , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep"-      , fsLit "WordRep"-      , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep"-      , fsLit "AddrRep"-      , fsLit "FloatRep", fsLit "DoubleRep"-      ]-      runtimeRepSimpleDataConKeys-      runtimeRepSimpleDataCons--vecCountTyConName :: Name-vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon---- See Note [Wiring in RuntimeRep]-vecCountDataConNames :: [Name]-vecCountDataConNames = zipWith3Lazy mk_special_dc_name-                         [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8"-                         , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ]-                         vecCountDataConKeys-                         vecCountDataCons--vecElemTyConName :: Name-vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon---- See Note [Wiring in RuntimeRep]-vecElemDataConNames :: [Name]-vecElemDataConNames = zipWith3Lazy mk_special_dc_name-                        [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep"-                        , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep"-                        , fsLit "Word32ElemRep", fsLit "Word64ElemRep"-                        , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]-                        vecElemDataConKeys-                        vecElemDataCons--mk_special_dc_name :: FastString -> Unique -> DataCon -> Name-mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc- boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR,     intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName boolTyCon_RDR   = nameRdrName boolTyConName@@ -609,7 +537,7 @@ pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcTyCon name cType tyvars cons   = mkAlgTyCon name-                (mkAnonTyConBinders VisArg tyvars)+                (mkAnonTyConBinders tyvars)                 liftedTypeKind                 (map (const Representational) tyvars)                 cType@@ -619,24 +547,41 @@                 False           -- Not in GADT syntax  pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon-pcDataCon n univs tys = pcDataConW n univs (map linear tys)--pcDataConW :: Name -> [TyVar] -> [Scaled Type] -> TyCon -> DataCon-pcDataConW n univs tys = pcDataConWithFixity False n univs+pcDataCon n univs tys+  = pcDataConWithFixity False n univs                       []    -- no ex_tvs                       univs -- the univs are precisely the user-written tyvars-                      tys+                      []    -- No theta+                      (map linear tys) +pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon+-- Used for data constructors whose arguments are all constraints.+-- Notably constraint tuples, Eq# etc.+pcDataConConstraint n univs theta+  = pcDataConWithFixity False n univs+                      []    -- No ex_tvs+                      univs -- The univs are precisely the user-written tyvars+                      theta -- All constraint arguments+                      []    -- No value arguments++-- Used for RuntimeRep and friends; things with PromDataConInfo+pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon+pcSpecialDataCon dc_name arg_tys tycon rri+  = pcDataConWithFixity' False dc_name+                         (dataConWorkerUnique (nameUnique dc_name)) rri+                         [] [] [] [] (map linear arg_tys) tycon+ pcDataConWithFixity :: Bool      -- ^ declared infix?                     -> Name      -- ^ datacon name                     -> [TyVar]   -- ^ univ tyvars                     -> [TyCoVar] -- ^ ex tycovars                     -> [TyCoVar] -- ^ user-written tycovars+                    -> ThetaType                     -> [Scaled Type]    -- ^ args                     -> TyCon                     -> DataCon-pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n))-                                                  NoRRI+pcDataConWithFixity infx n = pcDataConWithFixity' infx n+                                 (dataConWorkerUnique (nameUnique n)) NoPromInfo -- The Name's unique is the first of two free uniques; -- the first is used for the datacon itself, -- the second is used for the "worker name"@@ -644,9 +589,9 @@ -- To support this the mkPreludeDataConUnique function "allocates" -- one DataCon unique per pair of Ints. -pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo+pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo                      -> [TyVar] -> [TyCoVar] -> [TyCoVar]-                     -> [Scaled Type] -> TyCon -> DataCon+                     -> ThetaType -> [Scaled Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name -- of the DataCon itself. --@@ -658,7 +603,7 @@ --    to regret doing so (we do).  pcDataConWithFixity' declared_infix dc_name wrk_key rri-                     tyvars ex_tyvars user_tyvars arg_tys tycon+                     tyvars ex_tyvars user_tyvars theta arg_tys tycon   = data_con   where     tag_map = mkTyConTagMap tycon@@ -674,7 +619,7 @@                 tyvars ex_tyvars                 (mkTyVarBinders SpecifiedSpec user_tyvars)                 []      -- No equality spec-                []      -- No theta+                theta                 arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))                 rri                 tycon@@ -700,16 +645,11 @@     dc_occ  = nameOccName dc_name     wrk_occ = mkDataConWorkerOcc dc_occ --- used for RuntimeRep and friends-pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon-pcSpecialDataCon dc_name arg_tys tycon rri-  = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri-                         [] [] [] (map linear arg_tys) tycon  {- ************************************************************************ *                                                                      *-      Kinds+              Symbol *                                                                      * ************************************************************************ -}@@ -721,14 +661,7 @@ typeSymbolKind :: Kind typeSymbolKind = mkTyConTy typeSymbolKindCon -constraintKindTyCon :: TyCon--- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon!-constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] -typeToTypeKind, constraintKind :: Kind-typeToTypeKind   = liftedTypeKind `mkVisFunTyMany` liftedTypeKind-constraintKind   = mkTyConTy constraintKindTyCon- {- ************************************************************************ *                                                                      *@@ -868,7 +801,7 @@       ":"    -> Just consDataConName        -- function tycon-      "FUN"  -> Just funTyConName+      "FUN"  -> Just fUNTyConName       "->"  -> Just unrestrictedFunTyConName        -- boxed tuple data/tycon@@ -1162,7 +1095,7 @@                          (mkPrelTyConRepName tc_name)      klass     = mk_ctuple_class tycon sc_theta sc_sel_ids-    tuple_con = pcDataConW dc_name tvs (map unrestricted sc_theta) tycon+    tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon      binders = mkTemplateAnonTyConBinders (replicate arity constraintKind)     roles   = replicate arity Nominal@@ -1220,7 +1153,6 @@ unboxedUnitDataCon :: DataCon unboxedUnitDataCon = tupleDataCon Unboxed 0 - {- ********************************************************************* *                                                                      *       Unboxed sums@@ -1349,7 +1281,7 @@                              rhs klass                              (mkPrelTyConRepName eqTyConName)     klass     = mk_class tycon sc_pred sc_sel_id-    datacon   = pcDataConW eqDataConName tvs [unrestricted sc_pred] tycon+    datacon   = pcDataConConstraint eqDataConName tvs [sc_pred] tycon      -- Kind: forall k. k -> k -> Constraint     binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])@@ -1367,7 +1299,7 @@                              rhs klass                              (mkPrelTyConRepName heqTyConName)     klass     = mk_class tycon sc_pred sc_sel_id-    datacon   = pcDataConW heqDataConName tvs [unrestricted sc_pred] tycon+    datacon   = pcDataConConstraint heqDataConName tvs [sc_pred] tycon      -- Kind: forall k1 k2. k1 -> k2 -> Constraint     binders   = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id@@ -1385,7 +1317,7 @@                              rhs klass                              (mkPrelTyConRepName coercibleTyConName)     klass     = mk_class tycon sc_pred sc_sel_id-    datacon   = pcDataConW coercibleDataConName tvs [unrestricted sc_pred] tycon+    datacon   = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon      -- Kind: forall k. k -> k -> Constraint     binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])@@ -1419,12 +1351,20 @@ data Multiplicity = One | Many -} +multiplicityTyConName :: Name+multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")+                          multiplicityTyConKey multiplicityTyCon++oneDataConName, manyDataConName :: Name+oneDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon+manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon+ multiplicityTy :: Type multiplicityTy = mkTyConTy multiplicityTyCon  multiplicityTyCon :: TyCon multiplicityTyCon = pcTyCon multiplicityTyConName Nothing []-                          [oneDataCon, manyDataCon]+                            [oneDataCon, manyDataCon]  oneDataCon, manyDataCon :: DataCon oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon@@ -1450,19 +1390,21 @@   where     binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy] -unrestrictedFunTy :: Type-unrestrictedFunTy = functionWithMultiplicity manyDataConTy-+------------------------+-- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).+--              TYPE rep1 -> TYPE rep2 -> Type+-- type (->) = FUN 'Many unrestrictedFunTyCon :: TyCon-unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] unrestrictedFunTy-  where arrowKind = mkTyConKind binders liftedTypeKind-        -- See also funTyCon-        binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)-                  , Bndr runtimeRep2TyVar (NamedTCB Inferred)-                  ]-                  ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty-                                                , mkTYPEapp runtimeRep2Ty-                                                ]+unrestrictedFunTyCon+  = buildSynTyCon unrestrictedFunTyConName [] arrowKind []+                  (TyCoRep.TyConApp fUNTyCon [manyDataConTy])+  where+    arrowKind = mkTyConKind binders liftedTypeKind+    -- See also funTyCon+    binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)+              , Bndr runtimeRep2TyVar (NamedTCB Inferred) ]+              ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty+                                            , mkTYPEapp runtimeRep2Ty ]  unrestrictedFunTyConName :: Name unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->")@@ -1473,91 +1415,94 @@ *                                                                      *       Type synonyms (all declared in ghc-prim:GHC.Types) -         type Type         = TYPE LiftedRep    -- liftedTypeKind-         type UnliftedType = TYPE UnliftedRep  -- unliftedTypeKind-         type LiftedRep    = BoxedRep Lifted   -- liftedRepTy-         type UnliftedRep  = BoxedRep Unlifted -- unliftedRepTy+         type CONSTRAINT   :: RuntimeRep -> Type -- primitive; cONSTRAINTKind+         type Constraint   = CONSTRAINT LiftedRep  :: Type    -- constraintKind +         type TYPE         :: RuntimeRep -> Type  -- primitive; tYPEKind+         type Type         = TYPE LiftedRep   :: Type         -- liftedTypeKind+         type UnliftedType = TYPE UnliftedRep :: Type         -- unliftedTypeKind++         type LiftedRep    = BoxedRep Lifted   :: RuntimeRep  -- liftedRepTy+         type UnliftedRep  = BoxedRep Unlifted :: RuntimeRep  -- unliftedRepTy+ *                                                                      * ********************************************************************* -}  -- For these synonyms, see--- Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim, and+-- Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim, and -- Note [Using synonyms to compress types] in GHC.Core.Type +{- Note [Naked FunTy]+~~~~~~~~~~~~~~~~~~~~~+GHC.Core.TyCo.Rep.mkFunTy has assertions about the consistency of the argument+flag and arg/res types.  But when constructing the kinds of tYPETyCon and+cONSTRAINTTyCon we don't want to make these checks because+     TYPE :: RuntimeRep -> Type+i.e. TYPE :: RuntimeRep -> TYPE LiftedRep++so the check will loop infinitely.  Hence the use of a naked FunTy+constructor in tTYPETyCon and cONSTRAINTTyCon.+-}++ ------------------------- @type Type = TYPE ('BoxedRep 'Lifted)@+-- type Constraint = CONSTRAINT LiftedRep+constraintKindTyCon :: TyCon+constraintKindTyCon+  = buildSynTyCon constraintKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp cONSTRAINTTyCon [liftedRepTy]++constraintKindTyConName :: Name+constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint")+                                             constraintKindTyConKey constraintKindTyCon++constraintKind :: Kind+constraintKind = mkTyConTy constraintKindTyCon++----------------------+-- type Type = TYPE LiftedRep liftedTypeKindTyCon :: TyCon liftedTypeKindTyCon   = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs   where     rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy] -liftedTypeKind :: Type+liftedTypeKindTyConName :: Name+liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")+                                             liftedTypeKindTyConKey liftedTypeKindTyCon++liftedTypeKind, typeToTypeKind :: Type liftedTypeKind = mkTyConTy liftedTypeKindTyCon+typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind  ------------------------- | @type UnliftedType = TYPE ('BoxedRep 'Unlifted)@+-- type UnliftedType = TYPE ('BoxedRep 'Unlifted) unliftedTypeKindTyCon :: TyCon unliftedTypeKindTyCon   = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs   where     rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy] +unliftedTypeKindTyConName :: Name+unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType")+                                                unliftedTypeKindTyConKey unliftedTypeKindTyCon+ unliftedTypeKind :: Type unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon -------------------------- @type ZeroBitType = TYPE ZeroBitRep-zeroBitTypeTyCon :: TyCon-zeroBitTypeTyCon-  = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs-  where-    rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy] -zeroBitTypeKind :: Type-zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon--------------------------- | @type LiftedRep = 'BoxedRep 'Lifted@-liftedRepTyCon :: TyCon-liftedRepTyCon-  = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs-  where-    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy]--liftedRepTy :: RuntimeRepType-liftedRepTy = mkTyConTy liftedRepTyCon--------------------------- | @type UnliftedRep = 'BoxedRep 'Unlifted@-unliftedRepTyCon :: TyCon-unliftedRepTyCon-  = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs-  where-    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy]--unliftedRepTy :: RuntimeRepType-unliftedRepTy = mkTyConTy unliftedRepTyCon--------------------------- | @type ZeroBitRep = 'Tuple '[]-zeroBitRepTyCon :: TyCon-zeroBitRepTyCon-  = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs-  where-    rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]--zeroBitRepTy :: RuntimeRepType-zeroBitRepTy = mkTyConTy zeroBitRepTyCon-- {- ********************************************************************* *                                                                      *       data Levity = Lifted | Unlifted *                                                                      * ********************************************************************* -} +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+ levityTyCon :: TyCon levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon] @@ -1566,9 +1511,9 @@  liftedDataCon, unliftedDataCon :: DataCon liftedDataCon = pcSpecialDataCon liftedDataConName-    [] levityTyCon LiftedInfo+    [] levityTyCon (Levity Lifted) unliftedDataCon = pcSpecialDataCon unliftedDataConName-    [] levityTyCon UnliftedInfo+    [] levityTyCon (Levity Unlifted)  liftedDataConTyCon :: TyCon liftedDataConTyCon = promoteDataCon liftedDataCon@@ -1608,21 +1553,35 @@  runtimeRepTyCon :: TyCon runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []+    -- Here we list all the data constructors+    -- of the RuntimeRep data type     (vecRepDataCon : tupleRepDataCon :-     sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons)+     sumRepDataCon : boxedRepDataCon :+     runtimeRepSimpleDataCons)  runtimeRepTy :: Type runtimeRepTy = mkTyConTy runtimeRepTyCon +runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name+runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon++vecRepDataConName   = mk_runtime_rep_dc_name (fsLit "VecRep")   vecRepDataConKey   vecRepDataCon+tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon+sumRepDataConName   = mk_runtime_rep_dc_name (fsLit "SumRep")   sumRepDataConKey   sumRepDataCon+boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon++mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name+mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc+ boxedRepDataCon :: DataCon boxedRepDataCon = pcSpecialDataCon boxedRepDataConName   [ levityTy ] 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]+      = case tyConPromDataConInfo (tyConAppTyCon lev) of+          Levity Lifted   -> [LiftedRep]+          Levity Unlifted -> [UnliftedRep]           _ -> pprPanic "boxedRepDataCon" (ppr lev)     prim_rep_fun args       = pprPanic "boxedRepDataCon" (ppr args)@@ -1631,23 +1590,6 @@ boxedRepDataConTyCon :: TyCon boxedRepDataConTyCon = promoteDataCon boxedRepDataCon -vecRepDataCon :: DataCon-vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon-                                                   , mkTyConTy vecElemTyCon ]-                                 runtimeRepTyCon-                                 (RuntimeRep prim_rep_fun)-  where-    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType-    prim_rep_fun [count, elem]-      | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count)-      , VecElem  e <- tyConRuntimeRepInfo (tyConAppTyCon elem)-      = [VecRep n e]-    prim_rep_fun args-      = pprPanic "vecRepDataCon" (ppr args)--vecRepDataConTyCon :: TyCon-vecRepDataConTyCon = promoteDataCon vecRepDataCon- tupleRepDataCon :: DataCon tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ]                                    runtimeRepTyCon (RuntimeRep prim_rep_fun)@@ -1670,7 +1612,7 @@   where     -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType     prim_rep_fun [rr_ty_list]-      = map slotPrimRep (ubxSumRepType prim_repss)+      = map slotPrimRep (toList (ubxSumRepType prim_repss))       where         rr_tys     = extractPromotedList rr_ty_list         doc        = text "sumRepDataCon" <+> ppr rr_tys@@ -1685,18 +1627,27 @@ -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType runtimeRepSimpleDataCons :: [DataCon] runtimeRepSimpleDataCons-  = zipWithLazy mk_runtime_rep_dc-    [ IntRep-    , Int8Rep, Int16Rep, Int32Rep, Int64Rep-    , WordRep-    , Word8Rep, Word16Rep, Word32Rep, Word64Rep-    , AddrRep-    , FloatRep, DoubleRep-    ]-    runtimeRepSimpleDataConNames+  = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys+            [ (fsLit "IntRep",    IntRep)+            , (fsLit "Int8Rep",   Int8Rep)+            , (fsLit "Int16Rep",  Int16Rep)+            , (fsLit "Int32Rep",  Int32Rep)+            , (fsLit "Int64Rep",  Int64Rep)+            , (fsLit "WordRep",   WordRep)+            , (fsLit "Word8Rep",  Word8Rep)+            , (fsLit "Word16Rep", Word16Rep)+            , (fsLit "Word32Rep", Word32Rep)+            , (fsLit "Word64Rep", Word64Rep)+            , (fsLit "AddrRep",   AddrRep)+            , (fsLit "FloatRep",  FloatRep)+            , (fsLit "DoubleRep", DoubleRep) ]   where-    mk_runtime_rep_dc primrep name-      = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))+    mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon+    mk_runtime_rep_dc uniq (fs, primrep)+      = data_con+      where+        data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))+        dc_name  = mk_runtime_rep_dc_name fs uniq data_con  -- See Note [Wiring in RuntimeRep] intRepDataConTy,@@ -1714,17 +1665,108 @@    ]   = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons +----------------------+-- | @type ZeroBitRep = 'Tuple '[]+zeroBitRepTyCon :: TyCon+zeroBitRepTyCon+  = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]++zeroBitRepTyConName :: Name+zeroBitRepTyConName  = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep")+                                          zeroBitRepTyConKey  zeroBitRepTyCon++zeroBitRepTy :: RuntimeRepType+zeroBitRepTy = mkTyConTy zeroBitRepTyCon++----------------------+-- @type ZeroBitType = TYPE ZeroBitRep+zeroBitTypeTyCon :: TyCon+zeroBitTypeTyCon+  = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy]++zeroBitTypeTyConName :: Name+zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType")+                                          zeroBitTypeTyConKey zeroBitTypeTyCon++zeroBitTypeKind :: Type+zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon++----------------------+-- | @type LiftedRep = 'BoxedRep 'Lifted@+liftedRepTyCon :: TyCon+liftedRepTyCon+  = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy]++liftedRepTyConName :: Name+liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep")+                                        liftedRepTyConKey liftedRepTyCon++liftedRepTy :: RuntimeRepType+liftedRepTy = mkTyConTy liftedRepTyCon++----------------------+-- | @type UnliftedRep = 'BoxedRep 'Unlifted@+unliftedRepTyCon :: TyCon+unliftedRepTyCon+  = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy]++unliftedRepTyConName :: Name+unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep")+                                          unliftedRepTyConKey unliftedRepTyCon++unliftedRepTy :: RuntimeRepType+unliftedRepTy = mkTyConTy unliftedRepTyCon+++{- *********************************************************************+*                                                                      *+         VecCount, VecElem+*                                                                      *+********************************************************************* -}++vecCountTyConName :: Name+vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon++vecElemTyConName :: Name+vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon++vecRepDataCon :: DataCon+vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon+                                                   , mkTyConTy vecElemTyCon ]+                                 runtimeRepTyCon+                                 (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [count, elem]+      | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count)+      , VecElem  e <- tyConPromDataConInfo (tyConAppTyCon elem)+      = [VecRep n e]+    prim_rep_fun args+      = pprPanic "vecRepDataCon" (ppr args)++vecRepDataConTyCon :: TyCon+vecRepDataConTyCon = promoteDataCon vecRepDataCon+ vecCountTyCon :: TyCon vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons  -- See Note [Wiring in RuntimeRep] vecCountDataCons :: [DataCon]-vecCountDataCons = zipWithLazy mk_vec_count_dc-                     [ 2, 4, 8, 16, 32, 64 ]-                     vecCountDataConNames+vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys   where-    mk_vec_count_dc n name-      = pcSpecialDataCon name [] vecCountTyCon (VecCount n)+    mk_vec_count_dc logN key = con+      where+        n = 2^(logN :: Int)+        name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con+        con = pcSpecialDataCon name [] vecCountTyCon (VecCount n)  -- See Note [Wiring in RuntimeRep] vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,@@ -1737,14 +1779,19 @@  -- See Note [Wiring in RuntimeRep] vecElemDataCons :: [DataCon]-vecElemDataCons = zipWithLazy mk_vec_elem_dc-                    [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep-                    , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep-                    , FloatElemRep, DoubleElemRep ]-                    vecElemDataConNames+vecElemDataCons = zipWith3 mk_vec_elem_dc+  [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep"+  , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep"+  , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]+  [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep+  , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep+  , FloatElemRep, DoubleElemRep ]+    vecElemDataConKeys   where-    mk_vec_elem_dc elem name-      = pcSpecialDataCon name [] vecElemTyCon (VecElem elem)+    mk_vec_elem_dc nameFs elemRep key = con+      where+        name = mk_runtime_rep_dc_name nameFs key con+        con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep)  -- See Note [Wiring in RuntimeRep] int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,@@ -1763,30 +1810,6 @@ *                                                                      * ********************************************************************* -} -boxingDataCon_maybe :: TyCon -> Maybe DataCon---    boxingDataCon_maybe Char# = C#---    boxingDataCon_maybe Int#  = I#---    ... etc ...--- See Note [Boxing primitive types]-boxingDataCon_maybe tc-  = lookupNameEnv boxing_constr_env (tyConName tc)--boxing_constr_env :: NameEnv DataCon-boxing_constr_env-  = mkNameEnv [(charPrimTyConName  , charDataCon  )-              ,(intPrimTyConName   , intDataCon   )-              ,(wordPrimTyConName  , wordDataCon  )-              ,(floatPrimTyConName , floatDataCon )-              ,(doublePrimTyConName, doubleDataCon) ]--{- Note [Boxing primitive types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For a handful of primitive types (Int, Char, Word, Float, Double),-we can readily box and an unboxed version (Int#, Char# etc) using-the corresponding data constructor.  This is useful in a couple-of places, notably let-floating -}-- charTy :: Type charTy = mkTyConTy charTyCon @@ -1863,6 +1886,140 @@ doubleDataCon :: DataCon doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon +{- *********************************************************************+*                                                                      *+              Boxing data constructors+*                                                                      *+********************************************************************* -}++{- Note [Boxing constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep+that "box" unlifted values into a (boxed, lifted) value of kind Type. For example++  type Int8Box :: TYPE Int8Rep -> Type+  data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a+    -- MkInt8Box :: forall (a :: TYPE Int8Rep). a -> Int8Box a++Then we can package an `Int8#` into an `Int8Box` with `MkInt8Box`.  We can also+package up a (lifted) Constraint as a value of kind Type.++There are a fixed number of RuntimeReps, so we only need a fixed number+of boxing types.  (For TupleRep we need to box recursively; not yet done,+see #22336.)++This is used:++* In desugaring, when we need to package up a bunch of values into a tuple,+  for example when desugaring arrows.  See Note [Big tuples] in GHC.Core.Make.++* In let-floating when we want to float an unlifted sub-expression.+  See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels++In this module we make wired-in data type declarations for all of+these boxing functions.  The goal is to define boxingDataCon_maybe.++Wrinkles+(W1) The runtime system has special treatment (e.g. commoning up during GC)+     for Int and Char values. See  Note [CHARLIKE and INTLIKE closures] and+     Note [Precomputed static closures] in the RTS.++     So we treat Int# and Char# specially, in specialBoxingDataCon_maybe+-}++data BoxingInfo b+  = BI_NoBoxNeeded   -- The type has kind Type, so there is nothing to do++  | BI_NoBoxAvailable  -- The type does not have kind Type, but sadly we+                       -- don't have a boxing data constructor either++  | BI_Box             -- The type does not have kind Type, and we do have a+                       -- boxing data constructor; here it is+      { bi_data_con   :: DataCon+      , bi_inst_con   :: Expr b+      , bi_boxed_type :: Type }+    -- e.g. BI_Box { bi_data_con = I#, bi_inst_con = I#, bi_boxed_type = Int }+    --        recall: data Int = I# Int#+    --+    --      BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty+    --             , bi_boxed_type = Int8Box ty }A+    --        recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a++boxingDataCon :: Type -> BoxingInfo b+-- ^ Given a type 'ty', if 'ty' is not of kind Type, return a data constructor that+--   will box it, and the type of the boxed thing, which /does/ now have kind Type.+-- See Note [Boxing constructors]+boxingDataCon ty+  | tcIsLiftedTypeKind kind+  = BI_NoBoxNeeded    -- Fast path for Type++  | Just box_con <- specialBoxingDataCon_maybe ty+  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con []+           , bi_boxed_type = tyConNullaryTy (dataConTyCon box_con) }++  | Just box_con <- lookupTypeMap boxingDataConMap kind+  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [Type ty]+           , bi_boxed_type = mkTyConApp (dataConTyCon box_con) [ty] }++  | otherwise+  = BI_NoBoxAvailable++  where+    kind = typeKind ty++specialBoxingDataCon_maybe :: Type -> Maybe DataCon+-- ^ See Note [Boxing constructors] wrinkle (W1)+specialBoxingDataCon_maybe ty+  = case splitTyConApp_maybe ty of+      Just (tc, _) | tc `hasKey` intPrimTyConKey  -> Just intDataCon+                   | tc `hasKey` charPrimTyConKey -> Just charDataCon+      _ -> Nothing++boxingDataConMap :: TypeMap DataCon+-- See Note [Boxing constructors]+boxingDataConMap = foldl add emptyTypeMap boxingDataCons+  where+    add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con++boxingDataCons :: [(Kind, DataCon)]+-- The Kind is the kind of types for which the DataCon is the right boxing+boxingDataCons = zipWith mkBoxingDataCon+  (map mkBoxingTyConUnique [1..])+  [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox")+  , (mkTYPEapp intRepDataConTy,  fsLit "IntBox",  fsLit "MkIntBox")++  , (mkTYPEapp floatRepDataConTy,  fsLit "FloatBox",  fsLit "MkFloatBox")+  , (mkTYPEapp doubleRepDataConTy,  fsLit "DoubleBox",  fsLit "MkDoubleBox")++  , (mkTYPEapp int8RepDataConTy,  fsLit "Int8Box",  fsLit "MkInt8Box")+  , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box")+  , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box")+  , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box")++  , (mkTYPEapp word8RepDataConTy,  fsLit "Word8Box",   fsLit "MkWord8Box")+  , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box",  fsLit "MkWord16Box")+  , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box",  fsLit "MkWord32Box")+  , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box",  fsLit "MkWord64Box")++  , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox")+  , (constraintKind,   fsLit "DictBox", fsLit "MkDictBox") ]++mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon)+mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc)+  = (kind, dc)+  where+    uniq_dc = boxingDataConUnique uniq_tc++    (tv:_) = mkTemplateTyVars (repeat kind)+    tc = pcTyCon tc_name Nothing [tv] [dc]+    tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc++    dc | isConstraintKind kind+       = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc+       | otherwise+       = pcDataCon           dc_name [tv] [mkTyVarTy tv] tc+    dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc+ {- ************************************************************************ *                                                                      *@@ -1969,23 +2126,14 @@ consDataCon :: DataCon consDataCon = pcDataConWithFixity True {- Declared infix -}                consDataConName-               alpha_tyvar [] alpha_tyvar-               (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) listTyCon+               alpha_tyvar [] alpha_tyvar []+               (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])+               listTyCon+ -- Interesting: polymorphic recursion would help here. -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy -- gets the over-specific type (Type -> Type) --- NonEmpty lists (used for 'ProjectionE')-nonEmptyTyCon :: TyCon-nonEmptyTyCon = pcTyCon nonEmptyTyConName Nothing [alphaTyVar] [nonEmptyDataCon]--nonEmptyDataCon :: DataCon-nonEmptyDataCon = pcDataConWithFixity True {- Declared infix -}-                    nonEmptyDataConName-                    alpha_tyvar [] alpha_tyvar-                    (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])-                    nonEmptyTyCon- -- Wired-in type Maybe  maybeTyCon :: TyCon@@ -2075,7 +2223,7 @@ mkTupleTy1 :: Boxity -> [Type] -> Type mkTupleTy1 Boxed   tys  = mkTyConApp (tupleTyCon Boxed (length tys)) tys mkTupleTy1 Unboxed tys  = mkTyConApp (tupleTyCon Unboxed (length tys))-                                         (map getRuntimeRep tys ++ tys)+                                     (map getRuntimeRep tys ++ tys)  -- | Build the type of a small tuple that holds the specified type of thing -- Flattens 1-tuples. See Note [One-tuples].@@ -2084,6 +2232,18 @@  unitTy :: Type unitTy = mkTupleTy Boxed []++-- Make a constraint tuple, flattening a 1-tuple as usual+-- If we get a constraint tuple that is bigger than the pre-built+--   ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it won't+--   have an info table in the RTS, so we can't use it at runtime.  But+--   this is used only in filling in extra-constraint wildcards, so it+--   never is used at runtime anyway+--   See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures]+mkConstraintTupleTy :: [Type] -> Type+mkConstraintTupleTy [ty] = ty+mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys+  {- ********************************************************************* *                                                                      *

@@ -16,8 +16,8 @@  unitTy :: Type - liftedTypeKindTyConName :: Name+constraintKindTyConName :: Name  liftedTypeKind, unliftedTypeKind, zeroBitTypeKind :: Kind 

@@ -30,6 +30,8 @@         levity1TyVarInf, levity2TyVarInf,         levity1Ty, levity2Ty, +        alphaConstraintTyVar, alphaConstraintTy,+         openAlphaTyVar, openBetaTyVar, openGammaTyVar,         openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec,         openAlphaTy, openBetaTy, openGammaTy,@@ -41,13 +43,16 @@         multiplicityTyVar1, multiplicityTyVar2,          -- Kind constructors...-        tYPETyCon, tYPETyConName,+        tYPETyCon, tYPETyConName, tYPEKind,+        cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, -        -- Kinds-        mkTYPEapp,+        -- Arrows+        funTyFlagTyCon, isArrowTyCon,+        fUNTyCon,       fUNTyConName,+        ctArrowTyCon, ctArrowTyConName,+        ccArrowTyCon, ccArrowTyConName,+        tcArrowTyCon, tcArrowTyConName, -        functionWithMultiplicity,-        funTyCon, funTyConName,         unexposedPrimTyCons, exposedPrimTyCons, primTyCons,          charPrimTyCon,          charPrimTy, charPrimTyConName,@@ -121,45 +126,134 @@   , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy   , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy   , doubleElemRepDataConTy-  , multiplicityTy )+  , multiplicityTy+  , constraintKind ) -import GHC.Types.Var    ( TyVarBinder, TyVar+import {-# SOURCE #-} GHC.Types.TyThing( mkATyCon )+import {-# SOURCE #-} GHC.Core.Type ( mkTyConApp, getLevity )++import GHC.Core.TyCon+import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid+                         -- import loops which show up if you import Type instead++import GHC.Types.Var    ( TyVarBinder, TyVar,binderVar, binderVars                         , mkTyVar, mkTyVarBinder, mkTyVarBinders ) import GHC.Types.Name-import {-# SOURCE #-} GHC.Types.TyThing-import GHC.Core.TyCon import GHC.Types.SrcLoc import GHC.Types.Unique+ import GHC.Builtin.Uniques import GHC.Builtin.Names-import GHC.Data.FastString import GHC.Utils.Misc ( changeLast )-import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid-                         -- import loops which show up if you import Type instead-import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, mkTYPEapp, getLevity )+import GHC.Utils.Panic ( assertPpr )+import GHC.Utils.Outputable +import GHC.Data.FastString import Data.Char -{--************************************************************************+{- ********************************************************************* *                                                                      *-\subsection{Primitive type constructors}+             Building blocks *                                                                      *-************************************************************************+********************************************************************* -}++mk_TYPE_app :: Type -> Type+mk_TYPE_app rep = mkTyConApp tYPETyCon [rep]++mk_CONSTRAINT_app :: Type -> Type+mk_CONSTRAINT_app rep = mkTyConApp cONSTRAINTTyCon [rep]++mkPrimTc :: FastString -> Unique -> TyCon -> Name+mkPrimTc = mkGenPrimTc UserSyntax++mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name+mkBuiltInPrimTc = mkGenPrimTc BuiltInSyntax++mkGenPrimTc :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name+mkGenPrimTc built_in_syntax occ key tycon+  = mkWiredInName gHC_PRIM (mkTcOccFS occ)+                  key+                  (mkATyCon tycon)+                  built_in_syntax++-- | Create a primitive 'TyCon' with the given 'Name',+-- arguments of kind 'Type` with the given 'Role's,+-- and the given result kind representation.+--+-- Only use this in "GHC.Builtin.Types.Prim".+pcPrimTyCon :: Name+            -> [Role] -> RuntimeRepType -> TyCon+pcPrimTyCon name roles res_rep+  = mkPrimTyCon name binders result_kind roles+  where+    bndr_kis    = liftedTypeKind <$ roles+    binders     = mkTemplateAnonTyConBinders bndr_kis+    result_kind = mk_TYPE_app res_rep++-- | Create a primitive nullary 'TyCon' with the given 'Name'+-- and result kind representation.+--+-- Only use this in "GHC.Builtin.Types.Prim".+pcPrimTyCon0 :: Name -> RuntimeRepType -> TyCon+pcPrimTyCon0 name res_rep+  = pcPrimTyCon name [] res_rep++-- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last+-- argument is levity-polymorphic, where the levity argument is+-- implicit and comes before other arguments+--+-- Only use this in "GHC.Builtin.Types.Prim".+pcPrimTyCon_LevPolyLastArg :: Name+                           -> [Role] -- ^ roles of the arguments (must be non-empty),+                                     -- not including the implicit argument of kind 'Levity',+                                     -- which always has 'Nominal' role+                           -> RuntimeRepType  -- ^ representation of the fully-applied type+                           -> TyCon+pcPrimTyCon_LevPolyLastArg name roles res_rep+  = mkPrimTyCon name binders result_kind (Nominal : roles)+    where+      result_kind = mk_TYPE_app res_rep+      lev_bndr = mkNamedTyConBinder Inferred levity1TyVar+      binders  = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis+      lev_tv   = mkTyVarTy (binderVar lev_bndr)++      -- [ Type, ..., Type, TYPE (BoxedRep l) ]+      anon_bndr_kis = changeLast (liftedTypeKind <$ roles) $+                      mk_TYPE_app $+                      mkTyConApp boxedRepDataConTyCon [lev_tv]+++{- *********************************************************************+*                                                                      *+           Primitive type constructors+*                                                                      *+********************************************************************* -}++{- Note Note [Unexposed TyCons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A few primitive TyCons are "unexposed", meaning:+* We don't want users to be able to write them (see #15209);+  i.e. they aren't in scope, ever.  In particular they do not+  appear in the exports of GHC.Prim: see GHC.Builtin.Utils.ghcPrimExports++* We don't want users to see them in GHCi's @:browse@ output (see #12023). -}  primTyCons :: [TyCon] primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons --- | Primitive 'TyCon's that are defined in GHC.Prim but not exposed.--- It's important to keep these separate as we don't want users to be able to--- write them (see #15209) or see them in GHCi's @:browse@ output--- (see #12023).+-- | Primitive 'TyCon's that are defined in GHC.Prim but not "exposed".+-- See Note [Unexposed TyCons] unexposedPrimTyCons :: [TyCon] unexposedPrimTyCons-  = [ eqPrimTyCon-    , eqReprPrimTyCon-    , eqPhantPrimTyCon+  = [ eqPrimTyCon      -- (~#)+    , eqReprPrimTyCon  -- (~R#)+    , eqPhantPrimTyCon -- (~P#)++    -- These arrows are un-exposed for now+    , ctArrowTyCon  -- (=>)+    , ccArrowTyCon  -- (==>)+    , tcArrowTyCon  -- (-=>)     ]  -- | Primitive 'TyCon's that are defined in, and exported from, GHC.Prim.@@ -201,27 +295,13 @@     , stackSnapshotPrimTyCon     , promptTagPrimTyCon +    , fUNTyCon     , tYPETyCon-    , funTyCon+    , cONSTRAINTTyCon  #include "primop-vector-tycons.hs-incl"     ] -mkPrimTc :: FastString -> Unique -> TyCon -> Name-mkPrimTc fs unique tycon-  = mkWiredInName gHC_PRIM (mkTcOccFS fs)-                  unique-                  (mkATyCon tycon)        -- Relevant TyCon-                  UserSyntax--mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name-mkBuiltInPrimTc fs unique tycon-  = mkWiredInName gHC_PRIM (mkTcOccFS fs)-                  unique-                  (mkATyCon tycon)        -- Relevant TyCon-                  BuiltInSyntax-- charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName,   wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName,   addrPrimTyConName, floatPrimTyConName, doublePrimTyConName,@@ -279,13 +359,13 @@ threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon promptTagPrimTyConName        = mkPrimTc (fsLit "PromptTag#") promptTagPrimTyConKey promptTagPrimTyCon -{--************************************************************************+{- ********************************************************************* *                                                                      *-\subsection{Support code}+                Type variables *                                                                      *-************************************************************************+********************************************************************* -} +{- alphaTyVars is a list of type variables for use in templates:         ["a", "b", ..., "z", "t1", "t2", ... ] -}@@ -372,13 +452,16 @@  mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] -- Makes named, Specified binders-mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds]+mkTemplateKindTyConBinders kinds+  = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds]  mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder]-mkTemplateAnonTyConBinders kinds = mkAnonTyConBinders VisArg (mkTemplateTyVars kinds)+mkTemplateAnonTyConBinders kinds+  = mkAnonTyConBinders (mkTemplateTyVars kinds)  mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder]-mkTemplateAnonTyConBindersFrom n kinds = mkAnonTyConBinders VisArg (mkTemplateTyVarsFrom n kinds)+mkTemplateAnonTyConBindersFrom n kinds+  = mkAnonTyConBinders (mkTemplateTyVarsFrom n kinds)  alphaTyVars :: [TyVar] alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind@@ -389,6 +472,15 @@ alphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec, deltaTyVarSpec :: TyVarBinder (alphaTyVarSpec:betaTyVarSpec:gammaTyVarSpec:deltaTyVarSpec:_) = mkTyVarBinders Specified alphaTyVars +alphaConstraintTyVars :: [TyVar]+alphaConstraintTyVars = mkTemplateTyVars $ repeat constraintKind++alphaConstraintTyVar :: TyVar+(alphaConstraintTyVar:_) = alphaConstraintTyVars++alphaConstraintTy :: Type+alphaConstraintTy = mkTyVarTy alphaConstraintTyVar+ alphaTys :: [Type] alphaTys = mkTyVarTys alphaTyVars alphaTy, betaTy, gammaTy, deltaTy :: Type@@ -422,7 +514,9 @@ -- beta  :: TYPE r2 -- gamma :: TYPE r3 [openAlphaTyVar,openBetaTyVar,openGammaTyVar]-  = mkTemplateTyVars [mkTYPEapp runtimeRep1Ty, mkTYPEapp runtimeRep2Ty, mkTYPEapp runtimeRep3Ty]+  = mkTemplateTyVars [ mk_TYPE_app runtimeRep1Ty+                     , mk_TYPE_app runtimeRep2Ty+                     , mk_TYPE_app runtimeRep3Ty]  openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec :: TyVarBinder openAlphaTyVarSpec = mkTyVarBinder Specified openAlphaTyVar@@ -451,8 +545,8 @@ levPolyAlphaTyVar, levPolyBetaTyVar :: TyVar [levPolyAlphaTyVar, levPolyBetaTyVar] =   mkTemplateTyVars-    [mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity1Ty])-    ,mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity2Ty])]+    [ mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity1Ty])+    , mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity2Ty])] -- alpha :: TYPE ('BoxedRep l) -- beta  :: TYPE ('BoxedRep k) @@ -477,80 +571,280 @@ ************************************************************************ -} -funTyConName :: Name-funTyConName = mkPrimTcName UserSyntax (fsLit "FUN") funTyConKey funTyCon+{- Note [Function type constructors and FunTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have four distinct function type constructors, and a type synonym + FUN :: forall (m :: Multiplicity) ->+        forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+        TYPE rep1 -> TYPE rep2 -> Type++ (=>)  :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+          CONSTRAINT rep1 -> TYPE rep2 -> Type++ (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+          CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint++ (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+          TYPE rep1 -> CONSTRAINT rep2 -> Constraint++ type (->) = FUN Many++For efficiency, all four are always represented by+  FunTy { ft_af :: FunTyFlag, ft_mult :: Mult+        , ft_arg :: Type, ft_res :: Type }+rather than by using a TyConApp.++* The four TyCons FUN, (=>), (==>), (-=>) are all wired in.+  But (->) is just a regular synonym, with no special treatment;+  in particular it is not wired-in.++* The ft_af :: FunTyFlag distinguishes the four cases.+  See Note [FunTyFlag] in GHC.Types.Var.++* The ft_af field is redundant: it can always be gleaned from+  the kinds of ft_arg and ft_res.  See Note [FunTyFlag] in GHC.Types.Var.++* The ft_mult :: Mult field gives the first argument for FUN+  For the other three cases ft_mult is redundant; it is always Many.+  Note that of the four type constructors, only `FUN` takes a Multiplicity.++* Functions in GHC.Core.Type help to build and decompose `FunTy`.+  * funTyConAppTy_maybe+  * funTyFlagTyCon+  * tyConAppFun_maybe+  * splitFunTy_maybe+  Use them!+-}++funTyFlagTyCon :: FunTyFlag -> TyCon+-- `anonArgTyCon af` gets the TyCon that corresponds to the `FunTyFlag`+-- But be careful: fUNTyCon has a different kind to the others!+-- See Note [Function type constructors and FunTy]+funTyFlagTyCon FTF_T_T = fUNTyCon+funTyFlagTyCon FTF_T_C = tcArrowTyCon+funTyFlagTyCon FTF_C_T = ctArrowTyCon+funTyFlagTyCon FTF_C_C = ccArrowTyCon++isArrowTyCon :: TyCon -> Bool+-- We don't bother to look for plain (->), because this function+-- should only be used after unwrapping synonyms+isArrowTyCon tc+  = assertPpr (not (isTypeSynonymTyCon tc)) (ppr tc)+    getUnique tc `elem`+    [fUNTyConKey, ctArrowTyConKey, ccArrowTyConKey, tcArrowTyConKey]++fUNTyConName, ctArrowTyConName, ccArrowTyConName, tcArrowTyConName :: Name+fUNTyConName     = mkPrimTc        (fsLit "FUN") fUNTyConKey       fUNTyCon+ctArrowTyConName = mkBuiltInPrimTc (fsLit "=>")  ctArrowTyConKey ctArrowTyCon+ccArrowTyConName = mkBuiltInPrimTc (fsLit "==>") ccArrowTyConKey ccArrowTyCon+tcArrowTyConName = mkBuiltInPrimTc (fsLit "-=>") tcArrowTyConKey tcArrowTyCon+ -- | The @FUN@ type constructor. -- -- @ -- FUN :: forall (m :: Multiplicity) -> --        forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.---        TYPE rep1 -> TYPE rep2 -> *+--        TYPE rep1 -> TYPE rep2 -> Type -- @ -- -- The runtime representations quantification is left inferred. This -- means they cannot be specified with @-XTypeApplications@. -- -- This is a deliberate choice to allow future extensions to the--- function arrow. To allow visible application a type synonym can be--- defined:------ @--- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).---             TYPE rep1 -> TYPE rep2 -> Type--- type Arr = FUN 'Many--- @----funTyCon :: TyCon-funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm+-- function arrow.+fUNTyCon :: TyCon+fUNTyCon = mkPrimTyCon fUNTyConName tc_bndrs liftedTypeKind tc_roles   where     -- See also unrestrictedFunTyCon     tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1                , mkNamedTyConBinder Inferred runtimeRep1TyVar                , mkNamedTyConBinder Inferred runtimeRep2TyVar ]-               ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty-                                             , mkTYPEapp runtimeRep2Ty-                                             ]-    tc_rep_nm = mkPrelTyConRepName funTyConName+               ++ mkTemplateAnonTyConBinders [ mk_TYPE_app runtimeRep1Ty+                                             , mk_TYPE_app runtimeRep2Ty ]+    tc_roles = [Nominal, Nominal, Nominal, Representational, Representational] +-- (=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+--         CONSTRAINT rep1 -> TYPE rep2 -> Type+ctArrowTyCon :: TyCon+ctArrowTyCon = mkPrimTyCon ctArrowTyConName tc_bndrs liftedTypeKind tc_roles+  where+    -- See also unrestrictedFunTyCon+    tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar+               , mkNamedTyConBinder Inferred runtimeRep2TyVar ]+               ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty+                                             , mk_TYPE_app       runtimeRep2Ty ]+    tc_roles = [Nominal, Nominal, Representational, Representational]++-- (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+--          CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint+ccArrowTyCon :: TyCon+ccArrowTyCon = mkPrimTyCon ccArrowTyConName tc_bndrs constraintKind tc_roles+  where+    -- See also unrestrictedFunTyCon+    tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar+               , mkNamedTyConBinder Inferred runtimeRep2TyVar ]+               ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty+                                             , mk_CONSTRAINT_app runtimeRep2Ty ]+    tc_roles = [Nominal, Nominal, Representational, Representational]++-- (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+--          TYPE rep1 -> CONSTRAINT rep2 -> Constraint+tcArrowTyCon :: TyCon+tcArrowTyCon = mkPrimTyCon tcArrowTyConName tc_bndrs constraintKind tc_roles+  where+    -- See also unrestrictedFunTyCon+    tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar+               , mkNamedTyConBinder Inferred runtimeRep2TyVar ]+               ++ mkTemplateAnonTyConBinders [ mk_TYPE_app       runtimeRep1Ty+                                             , mk_CONSTRAINT_app runtimeRep2Ty ]+    tc_roles = [Nominal, Nominal, Representational, Representational]+ {- ************************************************************************ *                                                                      *-                Kinds+                Type and Constraint *                                                                      * ************************************************************************ -Note [TYPE and RuntimeRep]+Note [TYPE and CONSTRAINT]  aka Note [Type vs Constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~-All types that classify values have a kind of the form (TYPE rr), where+GHC distinguishes Type from Constraint throughout the compiler.+See GHC Proposal #518, and tickets #21623 and #11715. -    data RuntimeRep     -- Defined in ghc-prim:GHC.Types+All types that classify values have a kind of the form+  (TYPE rr) or (CONSTRAINT rr)+where the `RuntimeRep` parameter, rr, tells us how the value is represented+at runtime.  TYPE and CONSTRAINT are primitive type constructors.++See Note [RuntimeRep polymorphism] about the `rr` parameter.++There are a bunch of type synonyms and data types defined in the+library ghc-prim:GHC.Types.  All of them are also wired in to GHC, in+GHC.Builtin.Types++  type Constraint   = CONSTRAINT LiftedRep  :: Type++  type Type         = TYPE LiftedRep   :: Type+  type UnliftedType = TYPE UnliftedRep :: Type++  type LiftedRep    = BoxedRep Lifted   :: RuntimeRep+  type UnliftedRep  = BoxedRep Unlifted :: RuntimeRep++  data RuntimeRep     -- Defined in ghc-prim:GHC.Types       = BoxedRep Levity       | IntRep       | FloatRep       .. etc .. -    data Levity = Lifted | Unlifted--    rr :: RuntimeRep+  data Levity = Lifted | Unlifted -    TYPE :: RuntimeRep -> TYPE 'LiftedRep  -- Built in+We abbreviate '*' specially (with -XStarIsType), as if we had this:+    type * = Type  So for example:-    Int        :: TYPE ('BoxedRep 'Lifted)-    Array# Int :: TYPE ('BoxedRep 'Unlifted)-    Int#       :: TYPE 'IntRep-    Float#     :: TYPE 'FloatRep-    Maybe      :: TYPE ('BoxedRep 'Lifted) -> TYPE ('BoxedRep 'Lifted)+    Int        :: TYPE (BoxedRep Lifted)+    Array# Int :: TYPE (BoxedRep Unlifted)+    Int#       :: TYPE IntRep+    Float#     :: TYPE FloatRep+    Maybe      :: TYPE (BoxedRep Lifted) -> TYPE (BoxedRep Lifted)     (# , #)    :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) -We abbreviate '*' specially:-    type LiftedRep = 'BoxedRep 'Lifted-    type * = TYPE LiftedRep+    Eq Int       :: CONSTRAINT (BoxedRep Lifted)+    IP "foo" Int :: CONSTRAINT (BoxedRep Lifted)+    a ~ b        :: CONSTRAINT (BoxedRep Lifted)+    a ~# b       :: CONSTRAINT (TupleRep []) -The 'rr' parameter tells us how the value is represented at runtime.+Constraints are mostly lifted, but unlifted ones are useful too.+Specifically  (a ~# b) :: CONSTRAINT (TupleRep []) -Generally speaking, you can't be polymorphic in 'rr'.  E.g+Wrinkles++(W1) Type and Constraint are considered distinct throughout GHC. But they+     are not /apart/: see Note [Type and Constraint are not apart]++(W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and+     aBSENT_CONSTRAINT_ERROR_ID for vaues of kind Constraint.  Ditto noInlineId+     vs noInlieConstraintId in GHC.Types.Id.Make; see Note [inlineId magic].++(W3) We need a TypeOrConstraint flag in LitRubbish.++Note [Type and Constraint are not apart]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type and Constraint are not equal (eqType) but they are not /apart/+either. Reason (c.f. #7451):++* We want to allow newtype classes, where+    class C a where { op :: a -> a }++* The axiom for such a class will look like+    axiom axC a :: (C a :: Constraint) ~# (a->a :: Type)++* This axiom connects a type of kind Type with one of kind Constraint+  That is dangerous: kindCo (axC Int) :: Type ~N Constraint+  And /that/ is bad because we could have+     type family F a where+        F Type       = Int+        F Constraint = Bool+  So now we can prove Int ~N Bool, and all is lost.  We prevent this+  by saying that Type and Constraint are not Apart, which makes the+  above type family instances illegal.++So we ensure that Type and Constraint are not apart; or, more+precisely, that TYPE and CONSTRAINT are not apart.  This+non-apart-ness check is implemented in GHC.Core.Unify.unify_ty: look+for `maybeApart MARTypeVsConstraint`.++Note that, as before, nothing prevents writing instances like:++  instance C (Proxy @Type a) where ...++In particular, TYPE and CONSTRAINT (and the synonyms Type, Constraint+etc) are all allowed in instance heads. It's just that TYPE is not+apart from CONSTRAINT, which means that the above instance would+irretrievably overlap with:++  instance C (Proxy @Constraint a) where ...++Wrinkles++(W1) In GHC.Core.RoughMap.roughMtchTyConName we are careful to map+     TYPE and CONSTRAINT to the same rough-map key.  Reason:+     If we insert (F @Constraint tys) into a FamInstEnv, and look+     up (F @Type tys'), we /must/ ensure that the (C @Constraint tys)+     appears among the unifiables when we do the lookupRM' in+     GHC.Core.FamInstEnv.lookup_fam_inst_env'.  So for the RoughMap we+     simply pretend that they are the same type constructor.  If we+     don't, we'll treat them as fully apart, which is unsound.++(W2) We must extend this treatment to the different arrow types (see+     Note [Function type constructors and FunTy]): if we have+       FunCo (axC Int) <Int> :: (C Int => Int) ~ ((Int -> Int) -> Int),+     then we could extract an equality between (=>) and (->). We thus+     must ensure that (=>) and (->) (among the other arrow combinations)+     are not Apart. See the FunTy/FunTy case in GHC.Core.Unify.unify_ty.++(W3) Are (TYPE IntRep) and (CONSTRAINT WordRep) apart?  In truth yes,+     they are.  But it's easier to say that htey are not apart, by+     reporting "maybeApart" (which is always safe), rather than+     recurse into the arguments (whose kinds may be utterly different)+     to look for apartness inside them.  Again this is in+     GHC.Core.Unify.unify_ty.++(W4) We give a different Typeable instance for Type than for Constraint.+     For type classes instances (unlike type family instances) it is not+     /unsound/ for Type and Constraint to treated as fully distinct; and+     for Typeable is desirable to give them different TypeReps.+     Certainly,+       - both Type and Constraint must /have/ a TypeRep, and+       - they had better not be the same (else eqTypeRep would give us+         a proof Type ~N Constraint, which we do not want+     So in GHC.Tc.Instance.Class.matchTypeable, Type and Constraint are+     treated as separate TyCons; i.e. given no special treatment.++Note [RuntimeRep polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, you can't be polymorphic in `RuntimeRep`.  E.g    f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a]    f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ... This is no good: we could not generate code for 'f', because the@@ -575,85 +869,40 @@      (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)                      (a :: TYPE r1) (b :: TYPE r2).                      a -> b -> TYPE ('TupleRep '[r1, r2])- -} +---------------------- tYPETyCon :: TyCon-tYPETyConName :: Name- tYPETyCon = mkPrimTyCon tYPETyConName                         (mkTemplateAnonTyConBinders [runtimeRepTy])                         liftedTypeKind                         [Nominal] ------------------------------ ... and now their names+tYPETyConName :: Name+tYPETyConName = mkPrimTc (fsLit "TYPE") tYPETyConKey tYPETyCon --- If you edit these, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-tYPETyConName             = mkPrimTcName UserSyntax (fsLit "TYPE") tYPETyConKey tYPETyCon+tYPEKind :: Type+tYPEKind = mkTyConTy tYPETyCon -mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name-mkPrimTcName built_in_syntax occ key tycon-  = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax+----------------------+cONSTRAINTTyCon :: TyCon+cONSTRAINTTyCon = mkPrimTyCon cONSTRAINTTyConName+                              (mkTemplateAnonTyConBinders [runtimeRepTy])+                              liftedTypeKind+                              [Nominal] ------------------------------+cONSTRAINTTyConName :: Name+cONSTRAINTTyConName = mkPrimTc (fsLit "CONSTRAINT") cONSTRAINTTyConKey cONSTRAINTTyCon --- Given a Multiplicity, applies FUN to it.-functionWithMultiplicity :: Type -> Type-functionWithMultiplicity mul = TyConApp funTyCon [mul]+cONSTRAINTKind :: Type+cONSTRAINTKind = mkTyConTy cONSTRAINTTyCon -{--************************************************************************++{- ********************************************************************* *                                                                      *-   Basic primitive types (@Char#@, @Int#@, etc.)+       Basic primitive types (Char#, Int#, etc.) *                                                                      *-************************************************************************--}---- | Create a primitive 'TyCon' with the given 'Name',--- arguments of kind 'Type` with the given 'Role's,--- and the given result kind representation.------ Only use this in "GHC.Builtin.Types.Prim".-pcPrimTyCon :: Name-            -> [Role] -> RuntimeRepType -> TyCon-pcPrimTyCon name roles res_rep-  = mkPrimTyCon name binders result_kind roles-  where-    bndr_kis    = liftedTypeKind <$ roles-    binders     = mkTemplateAnonTyConBinders bndr_kis-    result_kind = mkTYPEapp res_rep---- | Create a primitive nullary 'TyCon' with the given 'Name'--- and result kind representation.------ Only use this in "GHC.Builtin.Types.Prim".-pcPrimTyCon0 :: Name -> RuntimeRepType -> TyCon-pcPrimTyCon0 name res_rep-  = pcPrimTyCon name [] res_rep---- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last--- argument is levity-polymorphic.------ Only use this in "GHC.Builtin.Types.Prim".-pcPrimTyCon_LevPolyLastArg :: Name-                           -> [Role] -- ^ roles of the arguments (must be non-empty),-                                     -- not including the implicit argument of kind 'Levity',-                                     -- which always has 'Nominal' role-                           -> RuntimeRepType  -- ^ representation of the fully-applied type-                           -> TyCon-pcPrimTyCon_LevPolyLastArg name roles res_rep-  = mkPrimTyCon name binders result_kind (Nominal : roles)-    where-      result_kind = mkTYPEapp res_rep-      lev_bndr = mkNamedTyConBinder Inferred levity1TyVar-      binders  = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis-      lev_tv   = mkTyVarTy (binderVar lev_bndr)--      -- [ Type, ..., Type, TYPE (BoxedRep l) ]-      anon_bndr_kis = changeLast (liftedTypeKind <$ roles)-                        (mkTYPEapp $ mkTyConApp boxedRepDataConTyCon [lev_tv])+********************************************************************* -}  charPrimTy :: Type charPrimTy      = mkTyConTy charPrimTyCon@@ -824,6 +1073,8 @@  * In addition (~) is magical syntax, as ~ is a reserved symbol.    It cannot be exported or imported. + * The data constructor of the class is "Eq#", not ":C~"+ Within GHC, ~ is called eqTyCon, and it is defined in GHC.Builtin.Types.  Historical note: prior to July 18 (~) was defined as a@@ -950,9 +1201,9 @@                       -- See Note [The equality types story] eqPrimTyCon  = mkPrimTyCon eqPrimTyConName binders res_kind roles   where-    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])+    -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id-    res_kind = unboxedTupleKind []+    res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy]     roles    = [Nominal, Nominal, Nominal, Nominal]  -- like eqPrimTyCon, but the type for *Representational* coercions@@ -961,9 +1212,9 @@ eqReprPrimTyCon :: TyCon   -- See Note [The equality types story] eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles   where-    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])+    -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id-    res_kind = unboxedTupleKind []+    res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy]     roles    = [Nominal, Nominal, Representational, Representational]  -- like eqPrimTyCon, but the type for *Phantom* coercions.@@ -972,9 +1223,9 @@ eqPhantPrimTyCon :: TyCon eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles   where-    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])+    -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id-    res_kind = unboxedTupleKind []+    res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy]     roles    = [Nominal, Nominal, Phantom, Phantom]  -- | Given a Role, what TyCon is the type of equality predicates at that role?

@@ -1,5 +0,0 @@-module GHC.Builtin.Types.Prim where--import GHC.Core.TyCon--tYPETyCon :: TyCon

@@ -13,8 +13,8 @@        -- * Getting the 'Unique's of 'Name's       -- ** Anonymous sums-    , mkSumTyConUnique-    , mkSumDataConUnique+    , mkSumTyConUnique, mkSumDataConUnique+       -- ** Tuples       -- *** Vanilla     , mkTupleTyConUnique@@ -45,6 +45,9 @@      , initExitJoinUnique +      -- Boxing data types+    , mkBoxingTyConUnique, boxingDataConUnique+     ) where  import GHC.Prelude@@ -60,7 +63,6 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.Maybe @@ -107,8 +109,9 @@  mkSumTyConUnique :: Arity -> Unique mkSumTyConUnique arity =-    assert (arity < 0x3f) $ -- 0x3f since we only have 6 bits to encode the-                            -- alternative+    assertPpr (arity <= 0x3f) (ppr arity) $+              -- 0x3f since we only have 6 bits to encode the+              -- alternative     mkUnique 'z' (arity `shiftL` 8 .|. 0xfc)  mkSumDataConUnique :: ConTagZ -> Arity -> Unique@@ -297,6 +300,7 @@         other a-z: lower case chars for unique supplies.  Used so far:          a       TypeChecking?+        b       Boxing tycons & datacons         c       StgToCmm/Renamer         d       desugarer         f       AbsC flattener@@ -310,6 +314,27 @@         u       Cmm pipeline         y       GHCi bytecode generator         z       anonymous sums++Note [Related uniques for wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* All wired in tycons actually use *two* uniques:+  * u: the TyCon itself+  * u+1: the TyConRepName of the TyCon (for use with TypeRep)+  The "+1" is implemented in tyConRepNameUnique.+  If this ever changes, make sure to also change the treatment for boxing tycons.++* All wired in datacons use *three* uniques:+  * u: the DataCon itself+  * u+1: its worker Id+  * u+2: the TyConRepName of the promoted TyCon+  No wired-in datacons have wrappers.+  The "+1" is implemented in dataConWorkerUnique and the "+2" is in dataConTyRepNameUnique.+  If this ever changes, make sure to also change the treatment for boxing tycons.++* Because boxing tycons (see Note [Boxing constructors] in GHC.Builtin.Types)+  come with both a tycon and a datacon, each one takes up five slots, combining+  the two cases above. Getting from the tycon to the datacon (by adding 2)+  is implemented in boxingDataConUnique. -}  mkAlphaTyVarUnique     :: Int -> Unique@@ -351,29 +376,48 @@ initExitJoinUnique :: Unique initExitJoinUnique = mkUnique 's' 0 - -------------------------------------------------- -- Wired-in type constructor keys occupy *two* slots:---    * u: the TyCon itself---    * u+1: the TyConRepName of the TyCon+-- See Note [Related uniques for wired-in things]  mkPreludeTyConUnique   :: Int -> Unique-mkPreludeTyConUnique i                = mkUnique '3' (2*i)+mkPreludeTyConUnique i = mkUnique '3' (2*i)  tyConRepNameUnique :: Unique -> Unique tyConRepNameUnique  u = incrUnique u  -------------------------------------------------- -- Wired-in data constructor keys occupy *three* slots:---    * u: the DataCon itself---    * u+1: its worker Id---    * u+2: the TyConRepName of the promoted TyCon--- Prelude data constructors are too simple to need wrappers.+-- See Note [Related uniques for wired-in things]  mkPreludeDataConUnique :: Int -> Unique-mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic+mkPreludeDataConUnique i = mkUnique '6' (3*i)    -- Must be alphabetic --------------------------------------------------- dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique dataConWorkerUnique  u = incrUnique u dataConTyRepNameUnique u = stepUnique u 2++--------------------------------------------------+-- The data constructors of RuntimeRep occupy *five* slots:+-- See Note [Related uniques for wired-in things]+--+--    Example: WordRep+--+-- * u: the TyCon of the boxing data type WordBox+-- * u+1: the TyConRepName of the boxing data type+-- * u+2: the DataCon for MkWordBox+-- * u+3: the worker id for MkWordBox+-- * u+4: the TyConRepName of the promoted TyCon 'MkWordBox+--+-- Note carefully that+-- * u,u+1 are in sync with the conventions for+--          wired-in type constructors, above+-- * u+2,u+3,u+4 are in sync with the conventions for+--               wired-in data constructors, above+-- A little delicate!++mkBoxingTyConUnique :: Int -> Unique+mkBoxingTyConUnique i = mkUnique 'b' (5*i)++boxingDataConUnique :: Unique -> Unique+boxingDataConUnique u = stepUnique u 2

@@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeApplications           #-} -- --  (c) The University of Glasgow 2002-2006 --@@ -115,7 +116,7 @@   ppr TupleInfo{..} = text "<size" <+> ppr tupleSize <+>                       text "stack" <+> ppr tupleNativeStackSize <+>                       text "regs"  <+>-                      ppr (map (text.show) $ regSetToList tupleRegs) <>+                      ppr (map (text @SDoc . show) $ regSetToList tupleRegs) <>                       char '>'  voidTupleInfo :: TupleInfo

@@ -282,8 +282,8 @@         -- ^ uninitialised data, N bytes long   | CmmString ByteString         -- ^ string of 8-bit values only, not zero terminated.-  | CmmFileEmbed FilePath-        -- ^ an embedded binary file+  | CmmFileEmbed FilePath Int+        -- ^ an embedded binary file and its byte length  instance OutputableP Platform CmmStatic where     pdoc = pprStatic@@ -292,7 +292,7 @@   ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit   ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n   ppr (CmmString _) = text "CmmString"-  ppr (CmmFileEmbed fp) = text "CmmFileEmbed" <+> text fp+  ppr (CmmFileEmbed fp _) = text "CmmFileEmbed" <+> text fp  -- Static data before SRT generation data GenCmmStatics (rawOnly :: Bool) where@@ -444,7 +444,7 @@     CmmStaticLit lit   -> nest 4 $ text "const" <+> pdoc platform lit <> semi     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')-    CmmFileEmbed path  -> nest 4 $ text "incbin " <+> text (show path)+    CmmFileEmbed path _ -> nest 4 $ text "incbin " <+> text (show path)  -- -------------------------------------------------------------------------- -- data sections

@@ -11,6 +11,7 @@ import GHC.Prelude  import GHC.Cmm.CLabel+import GHC.Data.FastString import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Unique@@ -43,4 +44,4 @@  infoTblLbl :: BlockId -> CLabel infoTblLbl label-  = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs+  = mkBlockInfoTableLabel (mkFCallName (getUnique label) (fsLit "block")) NoCafRefs

@@ -300,19 +300,21 @@   show = showPprUnsafe . pprDebugCLabel genericPlatform  data ModuleLabelKind-    = MLK_Initializer String+    = MLK_Initializer LexicalFastString     | MLK_InitializerArray-    | MLK_Finalizer String+    | MLK_Finalizer LexicalFastString     | MLK_FinalizerArray     | MLK_IPEBuffer     deriving (Eq, Ord) -instance Outputable ModuleLabelKind where-    ppr MLK_InitializerArray = text "init_arr"-    ppr (MLK_Initializer s)  = text ("init__" ++ s)-    ppr MLK_FinalizerArray   = text "fini_arr"-    ppr (MLK_Finalizer s)    = text ("fini__" ++ s)-    ppr MLK_IPEBuffer        = text "ipe_buf"+pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc+pprModuleLabelKind MLK_InitializerArray                    = text "init_arr"+pprModuleLabelKind (MLK_Initializer (LexicalFastString s)) = text "init__" <> ftext s+pprModuleLabelKind MLK_FinalizerArray                      = text "fini_arr"+pprModuleLabelKind (MLK_Finalizer (LexicalFastString s))   = text "fini__" <> ftext s+pprModuleLabelKind MLK_IPEBuffer                           = text "ipe_buf"+{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> SDoc #-}+{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  isIdLabel :: CLabel -> Bool isIdLabel IdLabel{} = True@@ -885,15 +887,15 @@ mkStringLitLabel :: Unique -> CLabel mkStringLitLabel                = StringLitLabel -mkInitializerStubLabel :: Module -> String -> CLabel-mkInitializerStubLabel mod s    = ModuleLabel mod (MLK_Initializer s)+mkInitializerStubLabel :: Module -> FastString -> CLabel+mkInitializerStubLabel mod s    = ModuleLabel mod (MLK_Initializer (LexicalFastString s))  mkInitializerArrayLabel :: Module -> CLabel mkInitializerArrayLabel mod     = ModuleLabel mod MLK_InitializerArray  -mkFinalizerStubLabel :: Module -> String -> CLabel-mkFinalizerStubLabel mod s      = ModuleLabel mod (MLK_Finalizer s)+mkFinalizerStubLabel :: Module -> FastString -> CLabel+mkFinalizerStubLabel mod s      = ModuleLabel mod (MLK_Finalizer (LexicalFastString s))  mkFinalizerArrayLabel :: Module -> CLabel mkFinalizerArrayLabel mod       = ModuleLabel mod MLK_FinalizerArray@@ -1204,12 +1206,15 @@ labelType (CmmLabel _ _ _ CmmRetInfo)           = DataLabel labelType (CmmLabel _ _ _ CmmRet)               = CodeLabel labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel+labelType (RtsLabel (RtsSelectorEntry _ _))     = CodeLabel labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel+labelType (RtsLabel (RtsApEntry _ _))           = CodeLabel labelType (RtsLabel (RtsApFast _))              = CodeLabel-labelType (RtsLabel RtsUnpackCStringInfoTable)  = CodeLabel+labelType (RtsLabel RtsUnpackCStringInfoTable)  = DataLabel labelType (RtsLabel RtsUnpackCStringUtf8InfoTable)-                                                = CodeLabel-labelType (RtsLabel _)                          = DataLabel+                                                = DataLabel+labelType (RtsLabel (RtsPrimOp _))              = CodeLabel+labelType (RtsLabel (RtsSlowFastTickyCtr _))    = DataLabel labelType (LocalBlockLabel _)                   = CodeLabel labelType (SRTLabel _)                          = DataLabel labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel@@ -1428,32 +1433,37 @@    = CStyle   -- ^ C label style (used by C and LLVM backends)    | AsmStyle -- ^ Asm label style (used by NCG backend) -pprAsmLabel :: Platform -> CLabel -> SDoc+pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc pprAsmLabel platform lbl = pprCLabelStyle platform AsmStyle lbl+{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> SDoc #-}+{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprCLabel :: Platform -> CLabel -> SDoc+pprCLabel :: IsLine doc => Platform -> CLabel -> doc pprCLabel platform lbl = pprCLabelStyle platform CStyle lbl+{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> SDoc #-}+{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  instance OutputableP Platform CLabel where   {-# INLINE pdoc #-} -- see Note [Bangs in CLabel]   pdoc !platform lbl = getPprStyle $ \pp_sty ->                         case pp_sty of                           PprDump{} -> pprCLabel platform lbl-                          _         -> pprPanic "Labels in code should be printed with pprCLabel or pprAsmLabel" (pprCLabel platform lbl)+                          _         -> let lbl_doc = (pprCLabel platform lbl)+                                       in pprTraceUserWarning (text "Labels in code should be printed with pprCLabel or pprAsmLabel" <> lbl_doc) lbl_doc -pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc+pprCLabelStyle :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel]   let     !use_leading_underscores = platformLeadingUnderscore platform      -- some platform (e.g. Darwin) require a leading "_" for exported asm     -- symbols-    maybe_underscore :: SDoc -> SDoc+    maybe_underscore :: doc -> doc     maybe_underscore doc = case sty of       AsmStyle | use_leading_underscores -> pp_cSEP <> doc       _                                  -> doc -    tempLabelPrefixOrUnderscore :: SDoc+    tempLabelPrefixOrUnderscore :: doc     tempLabelPrefixOrUnderscore = case sty of       AsmStyle -> asmTempLabelPrefix platform       CStyle   -> char '_'@@ -1505,14 +1515,14 @@      IdLabel name _cafs flavor -> case sty of-      AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor+      AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor                    where                       isRandomGenerated = not (isExternalName name)                       internalNamePrefix =                          if isRandomGenerated                             then asmTempLabelPrefix platform                             else empty-      CStyle   -> ppr name <> ppIdFlavor flavor+      CStyle   -> pprName name <> ppIdFlavor flavor     SRTLabel u       -> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"@@ -1549,7 +1559,7 @@                                  ]     RtsLabel (RtsPrimOp primop)-      -> maybe_underscore $ text "stg_" <> ppr primop+      -> maybe_underscore $ text "stg_" <> pprPrimOp primop     RtsLabel (RtsSlowFastTickyCtr pat)       -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr"@@ -1567,12 +1577,12 @@                             -- with a letter so the label will be legal assembly code.     HpcTicksLabel mod-      -> maybe_underscore $ text "_hpc_tickboxes_"  <> ppr mod <> text "_hpc"+      -> maybe_underscore $ text "_hpc_tickboxes_"  <> pprModule mod <> text "_hpc" -   CC_Label cc   -> maybe_underscore $ ppr cc-   CCS_Label ccs -> maybe_underscore $ ppr ccs-   IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform l <> text "_" <> ppr m <> text "_ipe")-   ModuleLabel mod kind        -> maybe_underscore $ ppr mod <> text "_" <> ppr kind+   CC_Label cc   -> maybe_underscore $ pprCostCentre cc+   CCS_Label ccs -> maybe_underscore $ pprCostCentreStack ccs+   IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform l <> text "_" <> pprModule m <> text "_ipe")+   ModuleLabel mod kind        -> maybe_underscore $ pprModule mod <> text "_" <> pprModuleLabelKind kind     CmmLabel _ _ fs CmmCode     -> maybe_underscore $ ftext fs    CmmLabel _ _ fs CmmData     -> maybe_underscore $ ftext fs@@ -1582,6 +1592,8 @@    CmmLabel _ _ fs CmmRetInfo  -> maybe_underscore $ ftext fs <> text "_info"    CmmLabel _ _ fs CmmRet      -> maybe_underscore $ ftext fs <> text "_ret"    CmmLabel _ _ fs CmmClosure  -> maybe_underscore $ ftext fs <> text "_closure"+{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc #-}+{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- Note [Internal proc labels] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1602,21 +1614,24 @@ -- | Generate a label for a procedure internal to a module (if -- 'Opt_ExposeAllSymbols' is enabled). -- See Note [Internal proc labels].-ppInternalProcLabel :: Module     -- ^ the current module+ppInternalProcLabel :: IsLine doc+                    => Module     -- ^ the current module                     -> CLabel-                    -> Maybe SDoc -- ^ the internal proc label+                    -> Maybe doc -- ^ the internal proc label ppInternalProcLabel this_mod (IdLabel nm _ flavour)   | isInternalName nm   = Just-     $ text "_" <> ppr this_mod+     $ text "_" <> pprModule this_mod     <> char '_'     <> ztext (zEncodeFS (occNameFS (occName nm)))     <> char '_'     <> pprUniqueAlways (getUnique nm)     <> ppIdFlavor flavour ppInternalProcLabel _ _ = Nothing+{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe SDoc #-}+{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppIdFlavor :: IdLabelInfo -> SDoc+ppIdFlavor :: IsLine doc => IdLabelInfo -> doc ppIdFlavor x = pp_cSEP <> case x of    Closure          -> text "closure"    InfoTable        -> text "info"@@ -1627,22 +1642,22 @@    IdTickyInfo TickyRednCounts       -> text "ct"    IdTickyInfo (TickyInferedTag unique)-      -> text "ct_inf_tag" <> char '_' <> ppr unique+      -> text "ct_inf_tag" <> char '_' <> pprUniqueAlways unique    ConEntry loc      ->       case loc of         DefinitionSite -> text "con_entry"         UsageSite m n ->-          ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry"+          pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_entry"    ConInfoTable k   ->     case k of       DefinitionSite -> text "con_info"       UsageSite m n ->-        ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info"+        pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_info"    ClosureTable     -> text "closure_tbl"    Bytes            -> text "bytes"    BlockInfoTable   -> text "info" -pp_cSEP :: SDoc+pp_cSEP :: IsLine doc => doc pp_cSEP = char '_'  @@ -1656,13 +1671,13 @@ -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. -asmTempLabelPrefix :: Platform -> SDoc  -- for formatting labels+asmTempLabelPrefix :: IsLine doc => Platform -> doc  -- for formatting labels asmTempLabelPrefix !platform = case platformOS platform of     OSDarwin -> text "L"     OSAIX    -> text "__L" -- follow IBM XL C's convention     _        -> text ".L" -pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc+pprDynamicLinkerAsmLabel :: IsLine doc => Platform -> DynamicLinkerLabelInfo -> doc -> doc pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =     case platformOS platform of       OSDarwin

@@ -5,4 +5,4 @@  data CLabel -pprCLabel :: Platform -> CLabel -> SDoc+pprCLabel :: IsLine doc => Platform -> CLabel -> doc

@@ -46,7 +46,6 @@ import GHC.Cmm.MachOp import GHC.Cmm.Type import GHC.Cmm.Reg-import GHC.Utils.Trace (pprTrace) import GHC.Utils.Panic (panic) import GHC.Utils.Outputable 

@@ -65,7 +65,6 @@   | MO_S_Neg  Width             -- unary -    -- Unsigned multiply/divide-  | MO_U_MulMayOflo Width       -- nonzero if unsigned multiply overflows   | MO_U_Quot Width             -- unsigned / (same semantics as WordQuotOp)   | MO_U_Rem  Width             -- unsigned % (same semantics as WordRemOp) @@ -251,7 +250,6 @@         MO_Ne _                 -> True         MO_Mul _                -> True         MO_S_MulMayOflo _       -> True-        MO_U_MulMayOflo _       -> True         MO_And _                -> True         MO_Or _                 -> True         MO_Xor _                -> True@@ -379,7 +377,6 @@     MO_S_Quot r         -> cmmBits r     MO_S_Rem  r         -> cmmBits r     MO_S_Neg  r         -> cmmBits r-    MO_U_MulMayOflo r   -> cmmBits r     MO_U_Quot r         -> cmmBits r     MO_U_Rem  r         -> cmmBits r @@ -473,7 +470,6 @@     MO_S_Quot r         -> [r,r]     MO_S_Rem  r         -> [r,r]     MO_S_Neg  r         -> [r]-    MO_U_MulMayOflo r   -> [r,r]     MO_U_Quot r         -> [r,r]     MO_U_Rem  r         -> [r,r] 

@@ -9,9 +9,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- -- CmmNode type for representation using Hoopl graphs.  module GHC.Cmm.Node (@@ -33,6 +30,7 @@ import GHC.Cmm.Expr import GHC.Cmm.Switch import GHC.Data.FastString+import GHC.Data.Pair import GHC.Types.ForeignCall import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout@@ -725,7 +723,7 @@ mapExpM _ (CmmTick _)               = Nothing mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e-mapExpM f (CmmStore addr e align)   = (\[addr', e'] -> CmmStore addr' e' align) `fmap` mapListM f [addr, e]+mapExpM f (CmmStore addr e align)   = (\ (Pair addr' e') -> CmmStore addr' e' align) `fmap` traverse f (Pair addr e) mapExpM _ (CmmBranch _)             = Nothing mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e

@@ -12,6 +12,7 @@     , localRegType       -- * Global registers     , GlobalReg(..), isArgReg, globalRegType+    , pprGlobalReg     , spReg, hpReg, spLimReg, hpLimReg, nodeReg     , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg     , node, baseReg@@ -296,7 +297,7 @@ instance OutputableP env GlobalReg where     pdoc _ = ppr -pprGlobalReg :: GlobalReg -> SDoc+pprGlobalReg :: IsLine doc => GlobalReg -> doc pprGlobalReg gr     = case gr of         VanillaReg n _ -> char 'R' <> int n@@ -324,6 +325,8 @@         GCFun          -> text "stg_gc_fun"         BaseReg        -> text "BaseReg"         PicBaseReg     -> text "PicBaseReg"+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> SDoc #-}+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable   -- convenient aliases

@@ -7,9 +7,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core (         -- * Main data types@@ -85,9 +82,8 @@         IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor,          -- * Core rule data types-        CoreRule(..), RuleBase,-        RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,-        RuleEnv(..), RuleOpts, mkRuleEnv, emptyRuleEnv,+        CoreRule(..),+        RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, RuleOpts,          -- ** Operations on 'CoreRule's         ruleArity, ruleName, ruleIdName, ruleActivation,@@ -105,7 +101,6 @@ import GHC.Core.Rules.Config ( RuleOpts ) import GHC.Types.Name import GHC.Types.Name.Set-import GHC.Types.Name.Env( NameEnv ) import GHC.Types.Literal import GHC.Types.Tickish import GHC.Core.DataCon@@ -1062,6 +1057,12 @@    M.  But it's painful, because it means we need to keep track of all    the orphan modules below us. + * The "visible orphan modules" are all the orphan module in the transitive+   closure of the imports of this module.++ * During instance lookup, we filter orphan instances depending on+   whether or not the instance is in a visible orphan module.+  * A non-orphan is not finger-printed separately.  Instead, for    fingerprinting purposes it is treated as part of the entity it    mentions on the LHS.  For example@@ -1076,12 +1077,20 @@  Orphan-hood is computed   * For class instances:-      when we make a ClsInst-    (because it is needed during instance lookup)+    when we make a ClsInst in GHC.Core.InstEnv.mkLocalInstance+      (because it is needed during instance lookup)+    See Note [When exactly is an instance decl an orphan?]+        in GHC.Core.InstEnv -  * For rules and family instances:-       when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule)-                     or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst)+  * For rules+    when we generate a CoreRule (GHC.Core.Rules.mkRule)++  * For family instances:+    when we generate an IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst)++Orphan-hood is persisted into interface files, in ClsInst, FamInst,+and CoreRules.+ -}  {-@@ -1096,49 +1105,6 @@ representation. -} --- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules-type RuleBase = NameEnv [CoreRule]-        -- The rules are unordered;-        -- we sort out any overlaps on lookup---- | A full rule environment which we can apply rules from.  Like a 'RuleBase',--- but it also includes the set of visible orphans we use to filter out orphan--- rules which are not visible (even though we can see them...)-data RuleEnv-    = RuleEnv { re_base          :: [RuleBase] -- See Note [Why re_base is a list]-              , re_visible_orphs :: ModuleSet-              }--mkRuleEnv :: RuleBase -> [Module] -> RuleEnv-mkRuleEnv rules vis_orphs = RuleEnv [rules] (mkModuleSet vis_orphs)--emptyRuleEnv :: RuleEnv-emptyRuleEnv = RuleEnv [] emptyModuleSet--{--Note [Why re_base is a list]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In Note [Overall plumbing for rules], it is explained that the final-RuleBase which we must consider is combined from 4 different sources.--During simplifier runs, the fourth source of rules is constantly being updated-as new interfaces are loaded into the EPS. Therefore just before we check to see-if any rules match we get the EPS RuleBase and combine it with the existing RuleBase-and then perform exactly 1 lookup into the new map.--It is more efficient to avoid combining the environments and store the uncombined-environments as we can instead perform 1 lookup into each environment and then combine-the results.--Essentially we use the identity:--> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2)->   = lookupNameEnv n rb1 ++ lookupNameEnv n rb2--The latter being more efficient as we don't construct an intermediate-map.--}  -- | A 'CoreRule' is: --

@@ -13,7 +13,9 @@ -- module GHC.Core.Coercion (         -- * Main data type-        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionN, MCoercionR,+        Coercion, CoercionN, CoercionR, CoercionP,+        MCoercion(..), MCoercionN, MCoercionR,+        CoSel(..), FunSel(..),         UnivCoProvenance, CoercionHole(..),         coHoleCoVar, setCoHoleCoVar,         LeftOrRight(..),@@ -35,8 +37,10 @@         mkAxInstLHS, mkUnbranchedAxInstLHS,         mkPiCo, mkPiCos, mkCoCast,         mkSymCo, mkTransCo,-        mkNthCo, mkNthCoFunCo, nthCoRole, mkLRCo,-        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunResCo,+        mkSelCo, getNthFun, getNthFromType, mkLRCo,+        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo,+        mkFunCo1, mkFunCo2, mkFunCoNoFTF, mkFunResCo,+        mkNakedFunCo1, mkNakedFunCo2,         mkForAllCo, mkForAllCos, mkHomoForAllCos,         mkPhantomCo,         mkHoleCo, mkUnivCo, mkSubCo,@@ -56,14 +60,13 @@         topNormaliseNewType_maybe, topNormaliseTypeX,          decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,-        splitTyConAppCo_maybe,         splitAppCo_maybe,         splitFunCo_maybe,         splitForAllCo_maybe,         splitForAllCo_ty_maybe, splitForAllCo_co_maybe, -        nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,-+        tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,+        tyConRoleListX, tyConRoleListRepresentational, funRole,         pickLR,          isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,@@ -118,7 +121,7 @@         -- * Other         promoteCoercion, buildCoercion, -        multToCo,+        multToCo, mkRuntimeRepCo,          hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy, @@ -135,17 +138,18 @@ import GHC.Core.TyCo.Ppr import GHC.Core.TyCo.Subst import GHC.Core.TyCo.Tidy+import GHC.Core.TyCo.Compare( eqType, eqTypeX ) import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Core.Coercion.Axiom-import {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name hiding ( varName ) import GHC.Types.Basic import GHC.Types.Unique+import GHC.Data.FastString import GHC.Data.Pair import GHC.Types.SrcLoc import GHC.Builtin.Names@@ -153,6 +157,8 @@ import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Types.Unique.FM+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf  import GHC.Utils.Misc import GHC.Utils.Outputable@@ -245,7 +251,7 @@                  -> TyCon -> CoAxBranch -> SDoc ppr_co_ax_branch ppr_rhs fam_tc branch   = foldr1 (flip hangNotEmpty 2)-    [ pprUserForAll (mkTyCoVarBinders Inferred bndrs')+    [ pprUserForAll (mkForAllTyBinders Inferred bndrs')          -- See Note [Printing foralls in type family instances] in GHC.Iface.Type     , pp_lhs <+> ppr_rhs tidy_env ee_rhs     , text "-- Defined" <+> pp_loc ]@@ -286,7 +292,7 @@         (env', bndr') = tidyVarBndr env bndr         env_wild = (occ_env, extendVarEnv subst bndr wild_bndr)         wild_bndr = setVarName bndr $-                    tidyNameOcc (varName bndr) (mkTyVarOcc "_")+                    tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_"))                     -- Tidy the binder to "_"      is_wildcard :: Var -> Bool@@ -359,9 +365,9 @@ mkPiMCos _ MRefl = MRefl mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co) -mkFunResMCo :: Scaled Type -> MCoercionR -> MCoercionR+mkFunResMCo :: Id -> MCoercionR -> MCoercionR mkFunResMCo _      MRefl    = MRefl-mkFunResMCo arg_ty (MCo co) = MCo (mkFunResCo Representational arg_ty co)+mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co)  mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion mkGReflLeftMCo r ty MRefl    = mkReflCo r ty@@ -386,48 +392,35 @@         Destructing coercions %*                                                                      * %************************************************************************--Note [Function coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~-Remember that-  (->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> TYPE LiftedRep-whose `RuntimeRep' arguments are intentionally marked inferred to-avoid type application.--Hence-  FunCo r mult co1 co2 :: (s1->t1) ~r (s2->t2)-is short for-  TyConAppCo (->) mult co_rep1 co_rep2 co1 co2-where co_rep1, co_rep2 are the coercions on the representations. -} - -- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into -- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: -- -- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] decomposeCo :: Arity -> Coercion-            -> [Role]  -- the roles of the output coercions-                       -- this must have at least as many-                       -- entries as the Arity provided+            -> Infinite Role  -- the roles of the output coercions             -> [Coercion] decomposeCo arity co rs-  = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ]-           -- Remember, Nth is zero-indexed+  = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ]+     -- Remember, SelTyCon is zero-indexed  decomposeFunCo :: HasDebugCallStack-               => Role      -- Role of the input coercion-               -> Coercion  -- Input coercion+               => Coercion  -- Input coercion                -> (CoercionN, Coercion, Coercion)--- Expects co :: (s1 -> t1) ~ (s2 -> t2)--- Returns (co1 :: s1~s2, co2 :: t1~t2)--- See Note [Function coercions] for the "3" and "4"+-- Expects co :: (s1 %m1-> t1) ~ (s2 %m2-> t2)+-- Returns (cow :: m1 ~N m2, co1 :: s1~s2, co2 :: t1~t2)+-- actually cow will be a Phantom coercion if the input is a Phantom coercion -decomposeFunCo _ (FunCo _ w co1 co2) = (w, co1, co2)-   -- Short-circuits the calls to mkNthCo+decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 })+  = (w, co1, co2)+   -- Short-circuits the calls to mkSelCo -decomposeFunCo r co = assertPpr all_ok (ppr co)-                      (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co)+decomposeFunCo co+  = assertPpr all_ok (ppr co) $+    ( mkSelCo (SelFun SelMult) co+    , mkSelCo (SelFun SelArg) co+    , mkSelCo (SelFun SelRes) co )   where     Pair s1t1 s2t2 = coercionKind co     all_ok = isFunTy s1t1 && isFunTy s2t2@@ -488,24 +481,25 @@         --          ty :: s2         -- need arg_co :: s2 ~ s1         --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]-      = let arg_co  = mkNthCo Nominal 0 (mkSymCo co)+      = let arg_co  = mkSelCo SelForAll (mkSymCo co)             res_co  = mkInstCo co (mkGReflLeftCo Nominal ty arg_co)             subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co)             subst2' = extendTCvSubst subst2 b ty         in         go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys -      | Just (_w1, _s1, t1) <- splitFunTy_maybe k1-      , Just (_w1, _s2, t2) <- splitFunTy_maybe k2+      | Just (af1, _w1, _s1, t1) <- splitFunTy_maybe k1+      , Just (af2, _w1, _s2, t2) <- splitFunTy_maybe k2+      , af1 == af2  -- Same sort of arrow         -- know     co :: (s1 -> t1) ~ (s2 -> t2)         --    function :: s1 -> t1         --          ty :: s2         -- need arg_co :: s2 ~ s1         --      res_co :: t1 ~ t2-      = let (_, sym_arg_co, res_co) = decomposeFunCo Nominal co-            -- It should be fine to ignore the multiplicity bit of the coercion-            -- for a Nominal coercion.-            arg_co               = mkSymCo sym_arg_co+      = let (_, sym_arg_co, res_co) = decomposeFunCo co+            -- It should be fine to ignore the multiplicity bit+            -- of the coercion for a Nominal coercion.+            arg_co = mkSymCo sym_arg_co         in         go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys @@ -526,19 +520,6 @@ getCoVar_maybe (CoVarCo cv) = Just cv getCoVar_maybe _            = Nothing --- | Attempts to tease a coercion apart into a type constructor and the application--- of a number of coercion arguments to that constructor-splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])-splitTyConAppCo_maybe co-  | Just (ty, r) <- isReflCo_maybe co-  = do { (tc, tys) <- splitTyConApp_maybe ty-       ; let args = zipWith mkReflCo (tyConRolesX r tc) tys-       ; return (tc, args) }-splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos)-splitTyConAppCo_maybe (FunCo _ w arg res)     = Just (funTyCon, cos)-  where cos = [w, mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res]-splitTyConAppCo_maybe _                     = Nothing- multToCo :: Mult -> Coercion multToCo r = mkNomReflCo r @@ -551,10 +532,10 @@   , Just (args', arg') <- snocView args   = Just ( mkTyConAppCo r tc args', arg' ) -  | not (mustBeSaturated tc)+  | not (tyConMustBeSaturated tc)     -- Never create unsaturated type family apps!   , Just (args', arg') <- snocView args-  , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg'+  , Just arg'' <- setNominalRole_maybe (tyConRole r tc (length args')) arg'   = Just ( mkTyConAppCo r tc args', arg'' )        -- Use mkTyConAppCo to preserve the invariant        --  that identity coercions are always represented by Refl@@ -567,7 +548,7 @@  -- Only used in specialise/Rules splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)-splitFunCo_maybe (FunCo _ _ arg res) = Just (arg, res)+splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res) splitFunCo_maybe _ = Nothing  splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)@@ -628,13 +609,13 @@   = pprPanic "eqTyConRole: unknown tycon" (ppr tc)  -- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@,+--   (or CONSTRAINT instead of TYPE) -- produce a coercion @rep_co :: r1 ~ r2@. mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion mkRuntimeRepCo co-  = mkNthCo Nominal 0 kind_co+  = mkSelCo (SelTyCon 0 Nominal) kind_co   where     kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2-                           -- (up to silliness with Constraint)  isReflCoVar_maybe :: Var -> Maybe Coercion -- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)@@ -707,7 +688,6 @@  Note [Role twiddling functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- There are a plethora of functions for twiddling roles:  mkSubCo: Requires a nominal input coercion and always produces a@@ -773,14 +753,10 @@ -- caller's responsibility to get the roles correct on argument coercions. mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkTyConAppCo r tc cos-  | [w, _rep1, _rep2, co1, co2] <- cos   -- See Note [Function coercions]-  , isFunTyCon tc-  = -- (a :: TYPE ra) -> (b :: TYPE rb)  ~  (c :: TYPE rc) -> (d :: TYPE rd)-    -- rep1 :: ra  ~  rc        rep2 :: rb  ~  rd-    -- co1  :: a   ~  c         co2  :: b   ~  d-    mkFunCo r w co1 co2+  | Just co <- tyConAppFunCo_maybe r tc cos+  = co -               -- Expand type synonyms+  -- Expand type synonyms   | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos   = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos @@ -790,18 +766,86 @@    | otherwise = TyConAppCo r tc cos +mkFunCoNoFTF :: HasDebugCallStack => Role -> CoercionN -> Coercion -> Coercion -> Coercion+-- This version of mkFunCo takes no FunTyFlags; it works them out+mkFunCoNoFTF r w arg_co res_co+  = mkFunCo2 r afl afr w arg_co res_co+  where+    afl = chooseFunTyFlag argl_ty resl_ty+    afr = chooseFunTyFlag argr_ty resr_ty+    Pair argl_ty argr_ty = coercionKind arg_co+    Pair resl_ty resr_ty = coercionKind res_co+ -- | Build a function 'Coercion' from two other 'Coercion's. That is, -- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@ -- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@.-mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion-mkFunCo r w co1 co2-    -- See Note [Refl invariant]-  | Just (ty1, _) <- isReflCo_maybe co1-  , Just (ty2, _) <- isReflCo_maybe co2-  , Just (w, _) <- isReflCo_maybe w-  = mkReflCo r (mkFunctionType w ty1 ty2)-  | otherwise = FunCo r w co1 co2+-- This (most common) version takes a single FunTyFlag, which is used+--   for both fco_afl and ftf_afr of the FunCo+mkFunCo1 :: HasDebugCallStack => Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkFunCo1 r af w arg_co res_co+  = mkFunCo2 r af af w arg_co res_co +mkNakedFunCo1 :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+-- This version of mkFunCo1 does not check FunCo invariants (checkFunCo)+-- It is called during typechecking on un-zonked types;+-- in particular there may be un-zonked coercion variables.+mkNakedFunCo1 r af w arg_co res_co+  = mkNakedFunCo2 r af af w arg_co res_co++mkFunCo2 :: HasDebugCallStack => Role -> FunTyFlag -> FunTyFlag+                              -> CoercionN -> Coercion -> Coercion -> Coercion+-- This is the smart constructor for FunCo; it checks invariants+mkFunCo2 r afl afr w arg_co res_co+  = assertPprMaybe (checkFunCo r afl afr w arg_co res_co) $+    mkNakedFunCo2 r afl afr w arg_co res_co++mkNakedFunCo2 :: Role -> FunTyFlag -> FunTyFlag+              -> CoercionN -> Coercion -> Coercion -> Coercion+-- This is the smart constructor for FunCo+-- "Naked"; it does not check invariants+mkNakedFunCo2 r afl afr w arg_co res_co+  | Just (ty1, _) <- isReflCo_maybe arg_co+  , Just (ty2, _) <- isReflCo_maybe res_co+  , Just (w, _)   <- isReflCo_maybe w+  = mkReflCo r (mkFunTy afl w ty1 ty2)  -- See Note [Refl invariant]++  | otherwise+  = FunCo { fco_role = r, fco_afl = afl, fco_afr = afr+          , fco_mult = w, fco_arg = arg_co, fco_res = res_co }+++checkFunCo :: Role -> FunTyFlag -> FunTyFlag+           -> CoercionN -> Coercion -> Coercion+           -> Maybe SDoc+-- Checks well-formed-ness for FunCo+-- Used only in assertions and Lint+{-# NOINLINE checkFunCo #-}+checkFunCo _r afl afr _w arg_co res_co+  | not (ok argl_ty && ok argr_ty && ok resl_ty && ok resr_ty)+  = Just (hang (text "Bad arg or res types") 2 pp_inputs)++  | afl == computed_afl+  , afr == computed_afr+  = Nothing+  | otherwise+  = Just (vcat [ text "afl (provided,computed):" <+> ppr afl <+> ppr computed_afl+               , text "afr (provided,computed):" <+> ppr afr <+> ppr computed_afr+               , pp_inputs ])+  where+    computed_afl = chooseFunTyFlag argl_ty resl_ty+    computed_afr = chooseFunTyFlag argr_ty resr_ty+    Pair argl_ty argr_ty = coercionKind arg_co+    Pair resl_ty resr_ty = coercionKind res_co++    pp_inputs = vcat [ pp_ty "argl" argl_ty, pp_ty "argr" argr_ty+                     , pp_ty "resl" resl_ty, pp_ty "resr" resr_ty+                     , text "arg_co:" <+> ppr arg_co+                     , text "res_co:" <+> ppr res_co ]++    ok ty = isTYPEorCONSTRAINT (typeKind ty)+    pp_ty str ty = text str <> colon <+> hang (ppr ty)+                                            2 (dcolon <+> ppr (typeKind ty))+ -- | Apply a 'Coercion' to another 'Coercion'. -- The second coercion must be Nominal, unless the first is Phantom. -- If the first is Phantom, then the second can be either Phantom or Nominal.@@ -818,15 +862,14 @@     -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)   = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)   where-    zip_roles (r1:_)  []            = [downgradeRole r1 Nominal arg]-    zip_roles (r1:rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys-    zip_roles _       _             = panic "zip_roles" -- but the roles are infinite...+    zip_roles (Inf r1 _)  []            = [downgradeRole r1 Nominal arg]+    zip_roles (Inf r1 rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys  mkAppCo (TyConAppCo r tc args) arg   = case r of       Nominal          -> mkTyConAppCo Nominal tc (args ++ [arg])       Representational -> mkTyConAppCo Representational tc (args ++ [arg'])-        where new_role = (tyConRolesRepresentational tc) !! (length args)+        where new_role = tyConRolesRepresentational tc Inf.!! length args               arg'     = downgradeRole new_role Nominal arg       Phantom          -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) mkAppCo co arg = AppCo co  arg@@ -899,11 +942,11 @@ mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo_NoRefl v kind_co co   | assert (varType v `eqType` (coercionLKind kind_co)) True-  , assert (isTyVar v || almostDevoidCoVarOfCo v co) True   , assert (not (isReflCo co)) True   , isCoVar v+  , assert (almostDevoidCoVarOfCo v co) True   , not (v `elemVarSet` tyCoVarsOfCo co)-  = FunCo (coercionRole co) (multToCo Many) kind_co co+  = mkFunCoNoFTF (coercionRole co) (multToCo ManyTy) kind_co co       -- Functions from coercions are always unrestricted   | otherwise   = ForAllCo v kind_co co@@ -1064,142 +1107,84 @@   = GRefl r t1 (MCo $ mkTransCo co1 co2) mkTransCo co1 co2                = TransCo co1 co2 -mkNthCo :: HasDebugCallStack-        => Role  -- The role of the coercion you're creating-        -> Int   -- Zero-indexed+mkSelCo :: HasDebugCallStack+        => CoSel         -> Coercion         -> Coercion-mkNthCo r n co-  = assertPpr good_call bad_call_msg $-    go n co+mkSelCo n co = mkSelCo_maybe n co `orElse` SelCo n co++mkSelCo_maybe :: HasDebugCallStack+        => CoSel+        -> Coercion+        -> Maybe Coercion+-- mkSelCo_maybe tries to optimise call to mkSelCo+mkSelCo_maybe cs co+  = assertPpr (good_call cs) bad_call_msg $+    go cs co   where     Pair ty1 ty2 = coercionKind co -    go 0 co-      | Just (ty, _) <- isReflCo_maybe co-      , Just (tv, _) <- splitForAllTyCoVar_maybe ty-      = -- works for both tyvar and covar-        assert (r == Nominal) $-        mkNomReflCo (varType tv)--    go n co-      | Just (ty, r0) <- isReflCo_maybe co-      , let tc = tyConAppTyCon ty-      = assertPpr (ok_tc_app ty n) (ppr n $$ ppr ty) $-        assert (nthRole r0 tc n == r) $-        mkReflCo r (tyConAppArgN n ty)-      where ok_tc_app :: Type -> Int -> Bool-            ok_tc_app ty n-              | Just (_, tys) <- splitTyConApp_maybe ty-              = tys `lengthExceeds` n-              | isForAllTy ty  -- nth:0 pulls out a kind coercion from a hetero forall-              = n == 0-              | otherwise-              = False+    go cs co+      | Just (ty, r) <- isReflCo_maybe co+      = Just (mkReflCo r (getNthFromType cs ty)) -    go 0 (ForAllCo _ kind_co _)-      = assert (r == Nominal)-        kind_co+    go SelForAll (ForAllCo _ kind_co _)+      = Just kind_co       -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)-      -- then (nth 0 co :: k1 ~N k2)+      -- then (nth SelForAll co :: k1 ~N k2)       -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)-      -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4))+      -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4)) -    go n (FunCo _ w arg res)-      = mkNthCoFunCo n w arg res+    go (SelFun fs) (FunCo _ _ _ w arg res)+      = Just (getNthFun fs w arg res) -    go n (TyConAppCo r0 tc arg_cos) = assertPpr (r == nthRole r0 tc n)-                                                  (vcat [ ppr tc-                                                        , ppr arg_cos-                                                        , ppr r0-                                                        , ppr n-                                                        , ppr r ]) $-                                             arg_cos `getNth` n+    go (SelTyCon i r) (TyConAppCo r0 tc arg_cos)+      = assertPpr (r == tyConRole r0 tc i)+                  (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $+        Just (arg_cos `getNth` i) -    go n (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo-      = mkSymCo (go n co)+    go cs (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo+      = do { co' <- go cs co; return (mkSymCo co') } -    go n co-      = NthCo r n co+    go _ _ = Nothing      -- Assertion checking     bad_call_msg = vcat [ text "Coercion =" <+> ppr co                         , text "LHS ty =" <+> ppr ty1                         , text "RHS ty =" <+> ppr ty2-                        , text "n =" <+> ppr n, text "r =" <+> ppr r+                        , text "cs =" <+> ppr cs                         , text "coercion role =" <+> ppr (coercionRole co) ]-    good_call-      -- If the Coercion passed in is between forall-types, then the Int must-      -- be 0 and the role must be Nominal.++    -- good_call checks the typing rules given in Note [SelCo]+    good_call SelForAll       | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1       , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2-      = n == 0 && r == Nominal--      -- If the Coercion passed in is between T tys and T tys', then the Int-      -- must be less than the length of tys/tys' (which must be the same-      -- lengths).-      ---      -- If the role of the Coercion is nominal, then the role passed in must-      -- be nominal. If the role of the Coercion is representational, then the-      -- role passed in must be tyConRolesRepresentational T !! n. If the role-      -- of the Coercion is Phantom, then the role passed in must be Phantom.-      ---      -- See also Note [NthCo Cached Roles] if you're wondering why it's-      -- blaringly obvious that we should be *computing* this role instead of-      -- passing it in.-      | Just (tc1, tys1) <- splitTyConApp_maybe ty1-      , Just (tc2, tys2) <- splitTyConApp_maybe ty2-      , tc1 == tc2-      = let len1 = length tys1-            len2 = length tys2-            good_role = case coercionRole co of-                          Nominal -> r == Nominal-                          Representational -> r == (tyConRolesRepresentational tc1 !! n)-                          Phantom -> r == Phantom-        in len1 == len2 && n < len1 && good_role--      | otherwise-      = True---- | Extract the nth field of a FunCo-mkNthCoFunCo :: Int         -- ^ "n"-             -> CoercionN   -- ^ multiplicity coercion-             -> Coercion    -- ^ argument coercion-             -> Coercion    -- ^ result coercion-             -> Coercion    -- ^ nth coercion from a FunCo--- See Note [Function coercions]--- If FunCo _ mult arg_co res_co ::   (s1:TYPE sk1 :mult-> s2:TYPE sk2)---                                  ~ (t1:TYPE tk1 :mult-> t2:TYPE tk2)--- Then we want to behave as if co was---    TyConAppCo mult argk_co resk_co arg_co res_co--- where---    argk_co :: sk1 ~ tk1  =  mkNthCo 0 (mkKindCo arg_co)---    resk_co :: sk2 ~ tk2  =  mkNthCo 0 (mkKindCo res_co)---                             i.e. mkRuntimeRepCo-mkNthCoFunCo n w co1 co2 = case n of-  0 -> w-  1 -> mkRuntimeRepCo co1-  2 -> mkRuntimeRepCo co2-  3 -> co1-  4 -> co2-  _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr w $$ ppr co1 $$ ppr co2)+      =  True --- | If you're about to call @mkNthCo r n co@, then @r@ should be--- whatever @nthCoRole n co@ returns.-nthCoRole :: Int -> Coercion -> Role-nthCoRole n co-  | Just (tc, _) <- splitTyConApp_maybe lty-  = nthRole r tc n+    good_call (SelFun {})+       = isFunTy ty1 && isFunTy ty2 -  | Just _ <- splitForAllTyCoVar_maybe lty-  = Nominal+    good_call (SelTyCon n r)+       | Just (tc1, tys1) <- splitTyConApp_maybe ty1+       , Just (tc2, tys2) <- splitTyConApp_maybe ty2+       , let { len1 = length tys1+             ; len2 = length tys2 }+       =  tc1 == tc2+       && len1 == len2+       && n < len1+       && r == tyConRole (coercionRole co) tc1 n -  | otherwise-  = pprPanic "nthCoRole" (ppr co)+    good_call _ = False -  where-    lty = coercionLKind co-    r   = coercionRole co+-- | Extract the nth field of a FunCo+getNthFun :: FunSel+          -> a    -- ^ multiplicity+          -> a    -- ^ argument+          -> a    -- ^ result+          -> a    -- ^ One of the above three+getNthFun SelMult mult _   _   = mult+getNthFun SelArg _     arg _   = arg+getNthFun SelRes _     _   res = res  mkLRCo :: LeftOrRight -> Coercion -> Coercion mkLRCo lr co@@ -1209,7 +1194,7 @@   = LRCo lr co  -- | Instantiates a 'Coercion'.-mkInstCo :: Coercion -> Coercion -> Coercion+mkInstCo :: Coercion -> CoercionN -> Coercion mkInstCo (ForAllCo tcv _kind_co body_co) co   | Just (arg, _) <- isReflCo_maybe co       -- works for both tyvar and covar@@ -1225,7 +1210,7 @@     -- instead of @isReflCo@   | otherwise = GRefl r ty (MCo co) --- | Given @ty :: k1@, @co :: k1 ~ k2@,+-- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@, -- produces @co' :: (ty |> co) ~r ty@ mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion mkGReflLeftCo r ty co@@ -1277,10 +1262,10 @@ mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co mkSubCo (TyConAppCo Nominal tc cos)   = TyConAppCo Representational tc (applyRoles tc cos)-mkSubCo (FunCo Nominal w arg res)-  = FunCo Representational w-          (downgradeRole Representational Nominal arg)-          (downgradeRole Representational Nominal res)+mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res })+  = co { fco_role = Representational+       , fco_arg = downgradeRole Representational Nominal arg+       , fco_res = downgradeRole Representational Nominal res } mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $              SubCo co @@ -1348,12 +1333,13 @@     setNominalRole_maybe_helper co@(Refl _) = Just co     setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co     setNominalRole_maybe_helper (TyConAppCo Representational tc cos)-      = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos+      = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos            ; return $ TyConAppCo Nominal tc cos' }-    setNominalRole_maybe_helper (FunCo Representational w co1 co2)+    setNominalRole_maybe_helper co@(FunCo { fco_role = Representational+                                          , fco_arg = co1, fco_res = co2 })       = do { co1' <- setNominalRole_maybe Representational co1            ; co2' <- setNominalRole_maybe Representational co2-           ; return $ FunCo Nominal w co1' co2'+           ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' }            }     setNominalRole_maybe_helper (SymCo co)       = SymCo <$> setNominalRole_maybe_helper co@@ -1363,10 +1349,10 @@       = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2     setNominalRole_maybe_helper (ForAllCo tv kind_co co)       = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co-    setNominalRole_maybe_helper (NthCo _r n co)+    setNominalRole_maybe_helper (SelCo n co)       -- NB, this case recurses via setNominalRole_maybe, not       -- setNominalRole_maybe_helper!-      = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co+      = SelCo n <$> setNominalRole_maybe (coercionRole co) co     setNominalRole_maybe_helper (InstCo co arg)       = InstCo <$> setNominalRole_maybe_helper co <*> pure arg     setNominalRole_maybe_helper (UnivCo prov _ co1 co2)@@ -1392,28 +1378,44 @@  -- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational applyRoles :: TyCon -> [Coercion] -> [Coercion]-applyRoles tc cos-  = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos+applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational --- the Role parameter is the Role of the TyConAppCo+-- The Role parameter is the Role of the TyConAppCo -- defined here because this is intimately concerned with the implementation -- of TyConAppCo -- Always returns an infinite list (with a infinite tail of Nominal)-tyConRolesX :: Role -> TyCon -> [Role]+tyConRolesX :: Role -> TyCon -> Infinite Role tyConRolesX Representational tc = tyConRolesRepresentational tc-tyConRolesX role             _  = repeat role+tyConRolesX role             _  = Inf.repeat role +tyConRoleListX :: Role -> TyCon -> [Role]+tyConRoleListX role = Inf.toList . tyConRolesX role+ -- Returns the roles of the parameters of a tycon, with an infinite tail -- of Nominal-tyConRolesRepresentational :: TyCon -> [Role]-tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal+tyConRolesRepresentational :: TyCon -> Infinite Role+tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal -nthRole :: Role -> TyCon -> Int -> Role-nthRole Nominal _ _ = Nominal-nthRole Phantom _ _ = Phantom-nthRole Representational tc n-  = (tyConRolesRepresentational tc) `getNth` n+-- Returns the roles of the parameters of a tycon, with an infinite tail+-- of Nominal+tyConRoleListRepresentational :: TyCon -> [Role]+tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational +tyConRole :: Role -> TyCon -> Int -> Role+tyConRole Nominal          _  _ = Nominal+tyConRole Phantom          _  _ = Phantom+tyConRole Representational tc n = tyConRolesRepresentational tc Inf.!! n++funRole :: Role -> FunSel -> Role+funRole Nominal          _  = Nominal+funRole Phantom          _  = Phantom+funRole Representational fs = funRoleRepresentational fs++funRoleRepresentational :: FunSel -> Role+funRoleRepresentational SelMult = Nominal+funRoleRepresentational SelArg  = Representational+funRoleRepresentational SelRes  = Representational+ ltRole :: Role -> Role -> Bool -- Is one role "less" than another? --     Nominal < Representational < Phantom@@ -1432,20 +1434,18 @@ -- First cases handles anything that should yield refl. promoteCoercion co = case co of -    _ | ki1 `eqType` ki2-      -> mkNomReflCo (typeKind ty1)-     -- no later branch should return refl-     --    The assert (False )s throughout-     -- are these cases explicitly, but they should never fire.--    Refl _ -> assert False $-              mkNomReflCo ki1+    Refl _ -> mkNomReflCo ki1 -    GRefl _ _ MRefl -> assert False $-                       mkNomReflCo ki1+    GRefl _ _ MRefl -> mkNomReflCo ki1      GRefl _ _ (MCo co) -> co +    _ | ki1 `eqType` ki2+      -> mkNomReflCo (typeKind ty1)+     -- No later branch should return refl+     -- The assert (False )s throughout+     -- are these cases explicitly, but they should never fire.+     TyConAppCo _ tc args       | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args       -> co'@@ -1463,14 +1463,19 @@       | isTyVar tv       -> promoteCoercion g -    ForAllCo _ _ _+    ForAllCo {}       -> assert False $+            -- (ForAllCo {} :: (forall cv.t1) ~ (forall cv.t2)+            -- The tyvar case is handled above, so the bound var is a+            -- a coercion variable. So both sides have kind Type+            -- (Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep).+            -- So the result is Refl, and that should have been caught by+            -- the first equation above          mkNomReflCo liftedTypeKind-      -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep -    FunCo _ _ _ _-      -> assert False $-         mkNomReflCo liftedTypeKind+    FunCo {} -> mkKindCo co+       -- We can get Type~Constraint or Constraint~Type+       -- from FunCo {} :: (a -> (b::Type)) ~ (a -=> (b'::Constraint))      CoVarCo {}     -> mkKindCo co     HoleCo {}      -> mkKindCo co@@ -1488,14 +1493,9 @@     TransCo co1 co2       -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) -    NthCo _ n co1-      | Just (_, args) <- splitTyConAppCo_maybe co1-      , args `lengthExceeds` n-      -> promoteCoercion (args !! n)--      | Just _ <- splitForAllCo_maybe co-      , n == 0-      -> assert False $ mkNomReflCo liftedTypeKind+    SelCo n co1+      | Just co' <- mkSelCo_maybe n co1+      -> promoteCoercion co'        | otherwise       -> mkKindCo co@@ -1519,7 +1519,7 @@            -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep      KindCo _-      -> assert False $+      -> assert False $ -- See the first equation above          mkNomReflCo liftedTypeKind      SubCo g@@ -1547,10 +1547,12 @@     -- w :: s1 ~ s2     -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2]   = Just $ mkInstCo g w'+   | isFunTy lty && isFunTy rty     -- g :: (t1 -> t2) ~ (t3 -> t4)     -- returns t2 ~ t4-  = Just $ mkNthCo Nominal 4 g -- extract result type, which is the 5th argument to (->)+  = Just $ mkSelCo (SelFun SelRes) g -- extract result type+   | otherwise -- one forall, one funty...   = Nothing @@ -1619,17 +1621,18 @@                   -- want it to be r. It is only called in 'mkPiCos', which is                   -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for                   -- now (Aug 2018) v won't occur in co.-                            mkFunResCo r scaled_ty co-              | otherwise = mkFunResCo r scaled_ty co-              where-                scaled_ty = Scaled (varMult v) (varType v)+                            mkFunResCo r v co+              | otherwise = mkFunResCo r v co -mkFunResCo :: Role -> Scaled Type -> Coercion -> Coercion--- Given res_co :: res1 -> res2,+mkFunResCo :: Role -> Id -> Coercion -> Coercion+-- Given res_co :: res1 ~ res2, --   mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2) -- Reflexive in the multiplicity argument-mkFunResCo role (Scaled mult arg_ty) res_co-  = mkFunCo role (multToCo mult) (mkReflCo role arg_ty) res_co+mkFunResCo role id res_co+  = mkFunCoNoFTF role mult arg_co res_co+  where+    arg_co = mkReflCo role (varType id)+    mult   = multToCo (varMult id)  -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 -- The first coercion might be lifted or unlifted; thus the ~? above@@ -1835,7 +1838,7 @@ We want to push the coercion inside the constructor application. So we do this -   g' :: t1~t2  =  Nth 0 g+   g' :: t1~t2  =  SelCo (SelTyCon 0) g     case K @t2 (x |> g' -> Maybe g') of      K (y:t2 -> Maybe t2) -> rhs@@ -1852,7 +1855,7 @@ Note [extendLiftingContextEx] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider we have datatype-  K :: \/k. \/a::k. P -> T k  -- P be some type+  K :: /\k. /\a::k. P -> T k  -- P be some type   g :: T k1 ~ T k2    case (K @k1 @t1 x) |> g of@@ -1860,7 +1863,7 @@  We want to push the coercion inside the constructor application. We first get the coercion mapped by the universal type variable k:-   lc = k |-> Nth 0 g :: k1~k2+   lc = k |-> SelCo (SelTyCon 0) g :: k1~k2  Here, the important point is that the kind of a is coerced, and P might be dependent on the existential type variable a.@@ -2027,14 +2030,14 @@   = go role ty   where     go :: Role -> Type -> Coercion-    go r ty                | Just ty' <- coreView ty-                           = go r ty'-    go Phantom ty          = lift_phantom ty-    go r (TyVarTy tv)      = expectJust "ty_co_subst bad roles" $-                             liftCoSubstTyVar lc r tv-    go r (AppTy ty1 ty2)   = mkAppCo (go r ty1) (go Nominal ty2)-    go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys)-    go r (FunTy _ w ty1 ty2) = mkFunCo r (go Nominal w) (go r ty1) (go r ty2)+    go r ty                 | Just ty' <- coreView ty+                            = go r ty'+    go Phantom ty           = lift_phantom ty+    go r (TyVarTy tv)       = expectJust "ty_co_subst bad roles" $+                              liftCoSubstTyVar lc r tv+    go r (AppTy ty1 ty2)    = mkAppCo (go r ty1) (go Nominal ty2)+    go r (TyConApp tc tys)  = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys)+    go r (FunTy af w t1 t2) = mkFunCo1 r af (go Nominal w) (go r t1) (go r t2)     go r t@(ForAllTy (Bndr v _) ty)        = let (lc', v', h) = liftCoSubstVarBndr lc v              body_co = ty_co_subst lc' r ty in@@ -2192,8 +2195,8 @@      role   = coVarRole old_var     eta'   = downgradeRole role Nominal eta-    eta1   = mkNthCo role 2 eta'-    eta2   = mkNthCo role 3 eta'+    eta1   = mkSelCo (SelTyCon 2 role) eta'+    eta2   = mkSelCo (SelTyCon 3 role) eta'      co1     = mkCoVarCo new_var     co2     = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2@@ -2285,7 +2288,8 @@ seqCo (AppCo co1 co2)           = seqCo co1 `seq` seqCo co2 seqCo (ForAllCo tv k co)        = seqType (varType tv) `seq` seqCo k                                                        `seq` seqCo co-seqCo (FunCo r w co1 co2)       = r `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2+seqCo (FunCo r af1 af2 w co1 co2) = r `seq` af1 `seq` af2 `seq`+                                    seqCo w `seq` seqCo co1 `seq` seqCo co2 seqCo (CoVarCo cv)              = cv `seq` () seqCo (HoleCo h)                = coHoleCoVar h `seq` () seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos@@ -2293,7 +2297,7 @@   = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 seqCo (SymCo co)                = seqCo co seqCo (TransCo co1 co2)         = seqCo co1 `seq` seqCo co2-seqCo (NthCo r n co)            = r `seq` n `seq` seqCo co+seqCo (SelCo n co)              = n `seq` seqCo co seqCo (LRCo lr co)              = lr `seq` seqCo co seqCo (InstCo co arg)           = seqCo co `seq` seqCo arg seqCo (KindCo co)               = seqCo co@@ -2344,25 +2348,27 @@ coercionLKind co   = go co   where-    go (Refl ty)                = ty-    go (GRefl _ ty _)           = ty-    go (TyConAppCo _ tc cos)    = mkTyConApp tc (map go cos)-    go (AppCo co1 co2)          = mkAppTy (go co1) (go co2)-    go (ForAllCo tv1 _ co1)     = mkTyCoInvForAllTy tv1 (go co1)-    go (FunCo _ w co1 co2)      = mkFunctionType (go w) (go co1) (go co2)-    go (CoVarCo cv)             = coVarLType cv-    go (HoleCo h)               = coVarLType (coHoleCoVar h)-    go (UnivCo _ _ ty1 _)       = ty1-    go (SymCo co)               = coercionRKind co-    go (TransCo co1 _)          = go co1-    go (LRCo lr co)             = pickLR lr (splitAppTy (go co))-    go (InstCo aco arg)         = go_app aco [go arg]-    go (KindCo co)              = typeKind (go co)-    go (SubCo co)               = go co-    go (NthCo _ d co)           = go_nth d (go co)-    go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)-    go (AxiomRuleCo ax cos)     = pFst $ expectJust "coercionKind" $-                                  coaxrProves ax $ map coercionKind cos+    go (Refl ty)                 = ty+    go (GRefl _ ty _)            = ty+    go (TyConAppCo _ tc cos)     = mkTyConApp tc (map go cos)+    go (AppCo co1 co2)           = mkAppTy (go co1) (go co2)+    go (ForAllCo tv1 _ co1)      = mkTyCoInvForAllTy tv1 (go co1)+    go (FunCo { fco_afl = af, fco_mult = mult, fco_arg = arg, fco_res = res})+       {- See Note [FunCo] -}    = FunTy { ft_af = af, ft_mult = go mult+                                         , ft_arg = go arg, ft_res = go res }+    go (CoVarCo cv)              = coVarLType cv+    go (HoleCo h)                = coVarLType (coHoleCoVar h)+    go (UnivCo _ _ ty1 _)        = ty1+    go (SymCo co)                = coercionRKind co+    go (TransCo co1 _)           = go co1+    go (LRCo lr co)              = pickLR lr (splitAppTy (go co))+    go (InstCo aco arg)          = go_app aco [go arg]+    go (KindCo co)               = typeKind (go co)+    go (SubCo co)                = go co+    go (SelCo d co)              = getNthFromType d (go co)+    go (AxiomInstCo ax ind cos)  = go_ax_inst ax ind (map go cos)+    go (AxiomRuleCo ax cos)      = pFst $ expectJust "coercionKind" $+                                   coaxrProves ax $ map coercionKind cos      go_ax_inst ax ind tys       | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs@@ -2382,42 +2388,48 @@     go_app (InstCo co arg) args = go_app co (go arg:args)     go_app co              args = piResultTys (go co) args -go_nth :: Int -> Type -> Type-go_nth d ty+getNthFromType :: HasDebugCallStack => CoSel -> Type -> Type+getNthFromType (SelFun fs) ty+  | Just (_af, mult, arg, res) <- splitFunTy_maybe ty+  = getNthFun fs mult arg res++getNthFromType (SelTyCon n _) ty   | Just args <- tyConAppArgs_maybe ty-  = assert (args `lengthExceeds` d) $-    args `getNth` d+  = assertPpr (args `lengthExceeds` n) (ppr n $$ ppr ty) $+    args `getNth` n -  | d == 0-  , Just (tv,_) <- splitForAllTyCoVar_maybe ty+getNthFromType SelForAll ty       -- Works for both tyvar and covar+  | Just (tv,_) <- splitForAllTyCoVar_maybe ty   = tyVarKind tv -  | otherwise-  = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty)+getNthFromType cs ty+  = pprPanic "getNthFromType" (ppr cs $$ ppr ty)  coercionRKind :: Coercion -> Type coercionRKind co   = go co   where-    go (Refl ty)                = ty-    go (GRefl _ ty MRefl)       = ty-    go (GRefl _ ty (MCo co1))   = mkCastTy ty co1-    go (TyConAppCo _ tc cos)    = mkTyConApp tc (map go cos)-    go (AppCo co1 co2)          = mkAppTy (go co1) (go co2)-    go (CoVarCo cv)             = coVarRType cv-    go (HoleCo h)               = coVarRType (coHoleCoVar h)-    go (FunCo _ w co1 co2)      = mkFunctionType (go w) (go co1) (go co2)-    go (UnivCo _ _ _ ty2)       = ty2-    go (SymCo co)               = coercionLKind co-    go (TransCo _ co2)          = go co2-    go (LRCo lr co)             = pickLR lr (splitAppTy (go co))-    go (InstCo aco arg)         = go_app aco [go arg]-    go (KindCo co)              = typeKind (go co)-    go (SubCo co)               = go co-    go (NthCo _ d co)           = go_nth d (go co)-    go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)-    go (AxiomRuleCo ax cos)     = pSnd $ expectJust "coercionKind" $-                                  coaxrProves ax $ map coercionKind cos+    go (Refl ty)                 = ty+    go (GRefl _ ty MRefl)        = ty+    go (GRefl _ ty (MCo co1))    = mkCastTy ty co1+    go (TyConAppCo _ tc cos)     = mkTyConApp tc (map go cos)+    go (AppCo co1 co2)           = mkAppTy (go co1) (go co2)+    go (CoVarCo cv)              = coVarRType cv+    go (HoleCo h)                = coVarRType (coHoleCoVar h)+    go (FunCo { fco_afr = af, fco_mult = mult, fco_arg = arg, fco_res = res})+       {- See Note [FunCo] -}    = FunTy { ft_af = af, ft_mult = go mult+                                         , ft_arg = go arg, ft_res = go res }+    go (UnivCo _ _ _ ty2)        = ty2+    go (SymCo co)                = coercionLKind co+    go (TransCo _ co2)           = go co2+    go (LRCo lr co)              = pickLR lr (splitAppTy (go co))+    go (InstCo aco arg)          = go_app aco [go arg]+    go (KindCo co)               = typeKind (go co)+    go (SubCo co)                = go co+    go (SelCo d co)              = getNthFromType d (go co)+    go (AxiomInstCo ax ind cos)  = go_ax_inst ax ind (map go cos)+    go (AxiomRuleCo ax cos)      = pSnd $ expectJust "coercionKind" $+                                   coaxrProves ax $ map coercionKind cos      go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar        | isGReflCo k_co           = mkTyCoInvForAllTy tv1 (go co1)@@ -2459,10 +2471,11 @@       | isCoVar cv1       = mkTyCoInvForAllTy cv2 (go_forall subst' co)       where-        k2 = coercionRKind k_co-        r         = coVarRole cv1-        eta1      = mkNthCo r 2 (downgradeRole r Nominal k_co)-        eta2      = mkNthCo r 3 (downgradeRole r Nominal k_co)+        k2    = coercionRKind k_co+        r     = coVarRole cv1+        k_co' = downgradeRole r Nominal k_co+        eta1  = mkSelCo (SelTyCon 2 r) k_co'+        eta2  = mkSelCo (SelTyCon 3 r) k_co'          -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)         -- k1    = t1 ~r t2@@ -2509,14 +2522,16 @@     go (TyConAppCo r _ _) = r     go (AppCo co1 _) = go co1     go (ForAllCo _ _ co) = go co-    go (FunCo r _ _ _) = r+    go (FunCo { fco_role = r }) = r     go (CoVarCo cv) = coVarRole cv     go (HoleCo h)   = coVarRole (coHoleCoVar h)     go (AxiomInstCo ax _ _) = coAxiomRole ax     go (UnivCo _ r _ _)  = r     go (SymCo co) = go co     go (TransCo co1 _co2) = go co1-    go (NthCo r _d _co) = r+    go (SelCo SelForAll      _co) = Nominal+    go (SelCo (SelTyCon _ r) _co) = r+    go (SelCo (SelFun fs)     co) = funRole (coercionRole co) fs     go (LRCo {}) = Nominal     go (InstCo co _) = go co     go (KindCo {}) = Nominal@@ -2610,20 +2625,21 @@                   ; _           -> False      }) $         mkNomReflCo ty1 -    go (FunTy { ft_mult = w1, ft_arg = arg1, ft_res = res1 })-       (FunTy { ft_mult = w2, ft_arg = arg2, ft_res = res2 })-      = mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2)+    go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 })+       (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 })+      = assert (af1 == af2) $+        mkFunCo1 Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2)      go (TyConApp tc1 args1) (TyConApp tc2 args2)       = assert (tc1 == tc2) $         mkTyConAppCo Nominal tc1 (zipWith go args1 args2)      go (AppTy ty1a ty1b) ty2-      | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2+      | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2       = mkAppCo (go ty1a ty2a) (go ty1b ty2b)      go ty1 (AppTy ty2a ty2b)-      | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1+      | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1       = mkAppCo (go ty1a ty2a) (go ty1b ty2b)      go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2)@@ -2651,8 +2667,8 @@              r    = coVarRole cv1             kind_co' = downgradeRole r Nominal kind_co-            eta1 = mkNthCo r 2 kind_co'-            eta2 = mkNthCo r 3 kind_co'+            eta1 = mkSelCo (SelTyCon 2 r) kind_co'+            eta2 = mkSelCo (SelTyCon 3 r) kind_co'              subst = mkEmptySubst $ mkInScopeSet $                       tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co

@@ -17,14 +17,16 @@ mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkAppCo :: Coercion -> Coercion -> Coercion mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion-mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion+mkFunCo1 :: HasDebugCallStack => Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkNakedFunCo1 :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkFunCo2 :: HasDebugCallStack => Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion mkCoVarCo :: CoVar -> Coercion mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkPhantomCo :: Coercion -> Type -> Type -> Coercion mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion mkSymCo :: Coercion -> Coercion mkTransCo :: Coercion -> Coercion -> Coercion-mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion+mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion mkLRCo :: LeftOrRight -> Coercion -> Coercion mkInstCo :: Coercion -> Coercion -> Coercion mkGReflCo :: Role -> Type -> MCoercionN -> Coercion

@@ -15,6 +15,7 @@  import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Coercion import GHC.Core.Type as Type hiding( substTyVarBndr, substTy ) import GHC.Core.TyCon@@ -23,6 +24,7 @@  import GHC.Types.Var.Set import GHC.Types.Var.Env+import GHC.Types.Unique.Set  import GHC.Data.Pair import GHC.Data.List.SetOps ( getNth )@@ -32,7 +34,6 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain-import GHC.Utils.Trace  import Control.Monad   ( zipWithM ) @@ -123,9 +124,20 @@ -- ^ optCoercion applies a substitution to a coercion, --   *and* optimises it to reduce its size optCoercion opts env co-  | optCoercionEnabled opts = optCoercion' env co-  | otherwise               = substCo env co+  | optCoercionEnabled opts+  = optCoercion' env co+{-+  = pprTrace "optCoercion {" (text "Co:" <+> ppr co) $+    let result = optCoercion' env co in+    pprTrace "optCoercion }" (vcat [ text "Co:" <+> ppr co+                                   , text "Optco:" <+> ppr result ]) $+    result+-} +  | otherwise+  = substCo env co++ optCoercion' :: Subst -> Coercion -> NormalCo optCoercion' env co   | debugIsOn@@ -136,19 +148,23 @@     assertPpr (substTyUnchecked env in_ty1 `eqType` out_ty1 &&                substTyUnchecked env in_ty2 `eqType` out_ty2 &&                in_role == out_role)-              ( text "optCoercion changed types!"-                 $$ hang (text "in_co:") 2 (ppr co)-                 $$ hang (text "in_ty1:") 2 (ppr in_ty1)-                 $$ hang (text "in_ty2:") 2 (ppr in_ty2)-                 $$ hang (text "out_co:") 2 (ppr out_co)-                 $$ hang (text "out_ty1:") 2 (ppr out_ty1)-                 $$ hang (text "out_ty2:") 2 (ppr out_ty2)-                 $$ hang (text "subst:") 2 (ppr env))-              out_co+              (hang (text "optCoercion changed types!")+                  2 (vcat [ text "in_co:" <+> ppr co+                          , text "in_ty1:" <+> ppr in_ty1+                          , text "in_ty2:" <+> ppr in_ty2+                          , text "out_co:" <+> ppr out_co+                          , text "out_ty1:" <+> ppr out_ty1+                          , text "out_ty2:" <+> ppr out_ty2+                          , text "in_role:" <+> ppr in_role+                          , text "out_role:" <+> ppr out_role+                          , vcat $ map ppr_one $ nonDetEltsUniqSet $ coVarsOfCo co+                          , text "subst:" <+> ppr env ]))+               out_co    | otherwise         = opt_co1 lc False co   where     lc = mkSubstLiftingContext env+    ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv)   type NormalCo    = Coercion@@ -191,9 +207,12 @@  -- See Note [Optimising coercion optimisation] -- | Optimize a non-phantom coercion.-opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo-+opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag+                      -> Role -> Coercion -> NormalCo+-- Precondition: In every call (opt_co4 lc sym rep role co)+--               we should have role = coercionRole co opt_co4_wrap = opt_co4+ {- opt_co4_wrap env sym rep r co   = pprTrace "opt_co4_wrap {"@@ -201,12 +220,13 @@            , text "Rep:" <+> ppr rep            , text "Role:" <+> ppr r            , text "Co:" <+> ppr co ]) $-    assert (r == coercionRole co )+    assert (r == coercionRole co )    $     let result = opt_co4 env sym rep r co in     pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $     result -} + opt_co4 env _   rep r (Refl ty)   = assertPpr (r == Nominal)               (text "Expected role:" <+> ppr r    $$@@ -246,7 +266,7 @@       (True, Nominal) ->         mkTyConAppCo Representational tc                      (zipWith3 (opt_co3 env sym)-                               (map Just (tyConRolesRepresentational tc))+                               (map Just (tyConRoleListRepresentational tc))                                (repeat Nominal)                                cos)       (False, Nominal) ->@@ -255,7 +275,7 @@                       -- must use opt_co2 here, because some roles may be P                       -- See Note [Optimising coercion optimisation]         mkTyConAppCo r tc (zipWith (opt_co2 env sym)-                                   (tyConRolesRepresentational tc)  -- the current roles+                                   (tyConRoleListRepresentational tc)  -- the current roles                                    cos)       (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) @@ -269,15 +289,17 @@                             opt_co4_wrap env' sym rep r co      -- Use the "mk" functions to check for nested Refls -opt_co4 env sym rep r (FunCo _r cow co1 co2)+opt_co4 env sym rep r (FunCo _r afl afr cow co1 co2)   = assert (r == _r) $-    if rep-    then mkFunCo Representational cow' co1' co2'-    else mkFunCo r cow' co1' co2'+    mkFunCo2 r' afl' afr' cow' co1' co2'   where     co1' = opt_co4_wrap env sym rep r co1     co2' = opt_co4_wrap env sym rep r co2     cow' = opt_co1 env sym cow+    !r' | rep       = Representational+        | otherwise = r+    !(afl', afr') | sym       = (afr,afl)+                  | otherwise = (afl,afr)  opt_co4 env sym rep r (CoVarCo cv)   | Just co <- lookupCoVar (lcSubst env) cv@@ -333,38 +355,29 @@     co2' = opt_co4_wrap env sym rep r co2     in_scope = lcInScopeSet env -opt_co4 env _sym rep r (NthCo _r n co)-  | Just (ty, _) <- isReflCo_maybe co-  , Just (_tc, args) <- assert (r == _r )-                        splitTyConApp_maybe ty-  = liftCoSubst (chooseRole rep r) env (args `getNth` n)--  | Just (ty, _) <- isReflCo_maybe co-  , n == 0-  , Just (tv, _) <- splitForAllTyCoVar_maybe ty-      -- works for both tyvar and covar-  = liftCoSubst (chooseRole rep r) env (varType tv)+opt_co4 env _sym rep r (SelCo n co)+  | Just (ty, _co_role) <- isReflCo_maybe co+  = liftCoSubst (chooseRole rep r) env (getNthFromType n ty)+    -- NB: it is /not/ true that r = _co_role+    --     Rather, r = coercionRole (SelCo n co) -opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos))+opt_co4 env sym rep r (SelCo (SelTyCon n r1) (TyConAppCo _ _ cos))   = assert (r == r1 )     opt_co4_wrap env sym rep r (cos `getNth` n)  -- see the definition of GHC.Builtin.Types.Prim.funTyCon-opt_co4 env sym rep r (NthCo r1 n (FunCo _r2 w co1 co2))-  = assert (r == r1 )-    opt_co4_wrap env sym rep r (mkNthCoFunCo n w co1 co2)+opt_co4 env sym rep r (SelCo (SelFun fs) (FunCo _r2 _afl _afr w co1 co2))+  = opt_co4_wrap env sym rep r (getNthFun fs w co1 co2) -opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _))+opt_co4 env sym rep _ (SelCo SelForAll (ForAllCo _ eta _))       -- works for both tyvar and covar-  = assert (r == _r )-    assert (n == 0 )-    opt_co4_wrap env sym rep Nominal eta+  = opt_co4_wrap env sym rep Nominal eta -opt_co4 env sym rep r (NthCo _r n co)-  | Just nth_co <- case co' of-      TyConAppCo _ _ cos -> Just (cos `getNth` n)-      FunCo _ w co1 co2  -> Just (mkNthCoFunCo n w co1 co2)-      ForAllCo _ eta _   -> Just eta+opt_co4 env sym rep r (SelCo n co)+  | Just nth_co <- case (co', n) of+      (TyConAppCo _ _ cos, SelTyCon n _) -> Just (cos `getNth` n)+      (FunCo _ _ _ w co1 co2, SelFun fs) -> Just (getNthFun fs w co1 co2)+      (ForAllCo _ eta _, SelForAll)      -> Just eta       _                  -> Nothing   = if rep && (r == Nominal)       -- keep propagating the SubCo@@ -372,7 +385,7 @@     else nth_co    | otherwise-  = wrapRole rep r $ NthCo r n co'+  = wrapRole rep r $ SelCo n co'   where     co' = opt_co1 env sym co @@ -455,8 +468,8 @@             -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2)             r2  = coVarRole cv             kind_co' = downgradeRole r2 Nominal kind_co-            n1 = mkNthCo r2 2 kind_co'-            n2 = mkNthCo r2 3 kind_co'+            n1 = mkSelCo (SelTyCon 2 r2) kind_co'+            n2 = mkSelCo (SelTyCon 3 r2) kind_co'          in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1                            (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) @@ -547,7 +560,7 @@   , equalLength tys1 tys2 -- see Note [Differing kinds]       -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);       -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps-  = let roles    = tyConRolesX role tc1+  = let roles    = tyConRoleListX role tc1         arg_cos  = zipWith3 (mkUnivCo prov') roles tys1 tys2         arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos     in@@ -577,9 +590,9 @@         eta   = mkUnivCo prov' Nominal k1 k2         eta_d = downgradeRole r' Nominal eta           -- eta gets opt'ed soon, but not yet.-        n_co  = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo`+        n_co  = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo`                 (mkCoVarCo cv1) `mkTransCo`-                (mkNthCo r' 3 eta_d)+                (mkSelCo (SelTyCon 3 r') eta_d)         ty2'  = substTyWithCoVars [cv2] [n_co] ty2          (env', cv1', eta') = optForAllCoBndr env sym cv1 eta@@ -651,13 +664,12 @@     mkGReflRightCo r1 t1 (opt_trans is co1 co2)  -- Push transitivity through matching destructors-opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2)+opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2)   | d1 == d2   , coercionRole co1 == coercionRole co2   , co1 `compatible_co` co2-  = assert (r1 == r2) $-    fireTransRule "PushNth" in_co1 in_co2 $-    mkNthCo r1 d1 (opt_trans is co1 co2)+  = fireTransRule "PushNth" in_co1 in_co2 $+    mkSelCo d1 (opt_trans is co1 co2)  opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)   | d1 == d2@@ -694,10 +706,14 @@     fireTransRule "PushTyConApp" in_co1 in_co2 $     mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) -opt_trans_rule is in_co1@(FunCo r1 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b)-  = assert (r1 == r2) $   -- Just like the TyConAppCo/TyConAppCo case+opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b)+                  in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b)+  = assert (r1 == r2)     $     -- Just like the TyConAppCo/TyConAppCo case+    assert (afr1 == afl2) $     fireTransRule "PushFun" in_co1 in_co2 $-    mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b)+    mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2)+                          (opt_trans is co1a co2a)+                          (opt_trans is co1b co2b)  opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)   -- Must call opt_trans_rule_app; see Note [EtaAppCo]@@ -772,8 +788,8 @@       is'  = is `extendInScopeSet` cv1       role = coVarRole cv1       eta1' = downgradeRole role Nominal eta1-      n1   = mkNthCo role 2 eta1'-      n2   = mkNthCo role 3 eta1'+      n1   = mkSelCo (SelTyCon 2 role) eta1'+      n2   = mkSelCo (SelTyCon 3 role) eta1'       r2'  = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo`                                         (mkCoVarCo cv1) `mkTransCo` n2])                     r2@@ -1134,9 +1150,9 @@  Here, -  h1   = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4)-  eta1 = mkNthCo r 2 h1      :: (s1 ~ s3)-  eta2 = mkNthCo r 3 h1      :: (s2 ~ s4)+  h1   = mkSelCo Nominal 0 g       :: (s1~s2)~(s3~s4)+  eta1 = mkSelCo (SelTyCon 2 r) h1 :: (s1 ~ s3)+  eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4)   h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) -} etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)@@ -1148,7 +1164,7 @@   | Pair ty1 ty2  <- coercionKind co   , Just (tv1, _) <- splitForAllTyVar_maybe ty1   , isForAllTy_ty ty2-  , let kind_co = mkNthCo Nominal 0 co+  , let kind_co = mkSelCo SelForAll co   = Just ( tv1, kind_co          , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) @@ -1164,13 +1180,13 @@   | Pair ty1 ty2  <- coercionKind co   , Just (cv1, _) <- splitForAllCoVar_maybe ty1   , isForAllTy_co ty2-  = let kind_co  = mkNthCo Nominal 0 co+  = let kind_co  = mkSelCo SelForAll co         r        = coVarRole cv1         l_co     = mkCoVarCo cv1         kind_co' = downgradeRole r Nominal kind_co-        r_co     = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo`-                   l_co `mkTransCo`-                   (mkNthCo r 3 kind_co')+        r_co     = mkSymCo (mkSelCo (SelTyCon 2 r) kind_co')+                   `mkTransCo` l_co+                   `mkTransCo` mkSelCo (SelTyCon 3 r) kind_co'     in Just ( cv1, kind_co             , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) @@ -1197,17 +1213,19 @@ etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] -- If possible, split a coercion --       g :: T s1 .. sn ~ T t1 .. tn--- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]+-- into [ SelCo (SelTyCon 0)     g :: s1~t1+--      , ...+--      , SelCo (SelTyCon (n-1)) g :: sn~tn ] etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)   = assert (tc == tc2) $ Just cos2  etaTyConAppCo_maybe tc co-  | not (mustBeSaturated tc)+  | not (tyConMustBeSaturated tc)   , (Pair ty1 ty2, r) <- coercionKindRole co   , Just (tc1, tys1)  <- splitTyConApp_maybe ty1   , Just (tc2, tys2)  <- splitTyConApp_maybe ty2   , tc1 == tc2-  , isInjectiveTyCon tc r  -- See Note [NthCo and newtypes] in GHC.Core.TyCo.Rep+  , isInjectiveTyCon tc r  -- See Note [SelCo and newtypes] in GHC.Core.TyCo.Rep   , let n = length tys1   , tys2 `lengthIs` n      -- This can fail in an erroneous program                            -- E.g. T a ~# T a b

@@ -185,10 +185,14 @@ -- -- 7) The original result type conLikeFullSig :: ConLike-               -> ([TyVar], [TyCoVar], [EqSpec]+               -> ([TyVar], [TyCoVar]                    -- Why tyvars for universal but tycovars for existential?                    -- See Note [Existential coercion variables] in GHC.Core.DataCon-                  , ThetaType, ThetaType, [Scaled Type], Type)+                  , [EqSpec]+                  , ThetaType      -- Provided theta+                  , ThetaType      -- Required theta+                  , [Scaled Type]  -- Arguments+                  , Type )         -- Result conLikeFullSig (RealDataCon con) =   let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con   -- Required theta is empty as normal data cons require no additional

@@ -20,7 +20,6 @@         -- ** Equality specs         EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,         eqSpecPair, eqSpecPreds,-        substEqSpec, filterEqSpec,          -- ** Field labels         FieldLabel(..), FieldLabelString,@@ -37,11 +36,11 @@         dataConDisplayType,         dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars,         dataConUserTyVars, dataConUserTyVarBinders,-        dataConEqSpec, dataConTheta,+        dataConTheta,         dataConStupidTheta,         dataConOtherTheta,         dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,-        dataConInstOrigArgTys, dataConRepArgTys,+        dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs,         dataConInstUnivs,         dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,         dataConSrcBangs,@@ -56,10 +55,10 @@         -- ** Predicates on DataCons         isNullarySrcDataCon, isNullaryRepDataCon,         isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon,-        isUnboxedSumDataCon,+        isUnboxedSumDataCon, isCovertGadtDataCon,         isVanillaDataCon, isNewDataCon, isTypeDataCon,         classDataCon, dataConCannotMatch,-        dataConUserTyVarsArePermuted,+        dataConUserTyVarsNeedWrapper, checkDataConTyVars,         isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,         specialPromotedDc, @@ -77,6 +76,7 @@ import GHC.Core.Unify import GHC.Core.TyCon import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Multiplicity import {-# SOURCE #-} GHC.Types.TyThing import GHC.Types.FieldLabel@@ -94,7 +94,7 @@ import GHC.Types.Unique.FM ( UniqFM ) import GHC.Types.Unique.Set import GHC.Builtin.Uniques( mkAlphaTyVarUnique )-+import GHC.Data.Graph.UnVar  -- UnVarSet and operations  import GHC.Utils.Outputable import GHC.Utils.Misc@@ -422,7 +422,7 @@                 --       syntax, provided its type looks like the above.                 --       The declaration format is held in the TyCon (algTcGadtSyntax) -        -- Universally-quantified type vars [a,b,c]+        -- dcUnivTyVars: Universally-quantified type vars [a,b,c]         -- INVARIANT: length matches arity of the dcRepTyCon         -- INVARIANT: result type of data con worker is exactly (T a b c)         -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with@@ -431,16 +431,16 @@          -- Existentially-quantified type and coercion vars [x,y]         -- For an example involving coercion variables,-        -- Why tycovars? See Note [Existential coercion variables]+        -- Why TyCoVars? See Note [Existential coercion variables]         dcExTyCoVars     :: [TyCoVar],          -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames         -- Reason: less confusing, and easier to generate Iface syntax          -- The type/coercion vars in the order the user wrote them [c,y,x,b]-        -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set-        --            of tyvars (*not* covars) of dcExTyCoVars unioned with the-        --            set of dcUnivTyVars whose tyvars do not appear in dcEqSpec+        -- INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders is+        --    exactly the set of tyvars (*not* covars) of dcExTyCoVars unioned+        --    with the set of dcUnivTyVars whose tyvars do not appear in dcEqSpec         -- See Note [DataCon user type variable binders]         dcUserTyVarBinders :: [InvisTVBinder], @@ -553,7 +553,7 @@   * Each argument flag is Inferred or Specified.    None are Required. (A DataCon is a term-level function; see-   Note [No Required TyCoBinder in terms] in GHC.Core.TyCo.Rep.)+   Note [No Required PiTyBinder in terms] in GHC.Core.TyCo.Rep.)  Why do we need the TyVarBinders, rather than just the TyVars?  So that we can construct the right type for the DataCon with its foralls@@ -565,23 +565,23 @@  Note [Existential coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- For now (Aug 2018) we can't write coercion quantifications in source Haskell, but we can in Core. Consider having:    data T :: forall k. k -> k -> Constraint where-    MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co))-        => T k a b+    MkT :: forall k (a::k) (b::k).+           forall k' (c::k') (co::k'~k).+           (b ~# (c|>co)) => T k a b    dcUnivTyVars       = [k,a,b]   dcExTyCoVars       = [k',c,co]   dcUserTyVarBinders = [k,a,k',c]-  dcEqSpec           = [b~(c|>co)]+  dcEqSpec           = [b ~# (c|>co)]   dcOtherTheta       = []   dcOrigArgTys       = []   dcRepTyCon         = T -  Function call 'dataConKindEqSpec' returns [k'~k]+Function call 'dataConKindEqSpec' returns [k'~k]  Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~@@ -593,6 +593,31 @@  Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A DataCon has two different sets of type variables:++* dcUserTyVarBinders, for the type variables binders in the order in which they+  originally arose in the user-written type signature.++  - They are the forall'd binders of the data con /wrapper/, which the user calls.++  - Their order *does* matter for TypeApplications, so they are full TyVarBinders,+    complete with visibilities.++* dcUnivTyVars and dcExTyCoVars, for the "true underlying" (i.e. of the data+  con worker) universal type variable and existential type/coercion variables,+  respectively.++  - They (i.e. univ ++ ex) are the forall'd variables of the data con /worker/++  - Their order is irrelevant for the purposes of TypeApplications,+    and as a consequence, they do not come equipped with visibilities+    (that is, they are TyVars/TyCoVars instead of ForAllTyBinders).++Often (dcUnivTyVars ++ dcExTyCoVars) = dcUserTyVarBinders; but they may differ+for three reasons, coming next:++--- Reason (R1): Order of quantification in GADT syntax ---+ In System FC, data constructor type signatures always quantify over all of their universal type variables, followed by their existential type variables. Normally, this isn't a problem, as most datatypes naturally quantify their type@@ -635,36 +660,119 @@ performs a stable topological sort on the type variables in the user-written type signature, which would place `b` before `a`. -But as noted above, enacting this behavior is not entirely trivial, as System-FC demands the variables go in universal-then-existential order under the hood.-Our solution is thus to equip DataCon with two different sets of type-variables:+--- Reason (R2): GADT constructors quantify over different variables --- -* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential-  type/coercion variables, respectively. Their order is irrelevant for the-  purposes of TypeApplications, and as a consequence, they do not come equipped-  with visibilities (that is, they are TyVars/TyCoVars instead of-  TyCoVarBinders).+GADT constructors may quantify over different variables than the worker+would.  Consider+   data T a b where+      MkT :: forall c d. c -> T [c] d -* dcUserTyVarBinders, for the type variables binders in the order in which they-  originally arose in the user-written type signature. Their order *does* matter-  for TypeApplications, so they are full TyVarBinders, complete with-  visibilities.+The dcUserTyVarBinders must be [c, d] -- that's what the user quantified over.+But c is actually existential, as it is not equal to either of the two+universal variables. -This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders-consists precisely of:+Here is what we'll get: +  dcUserTyVarBinders = [c, d]+  dcUnivTyVars = [a, d]+  dcExTyCoVars = [c]++Note that dcUnivTyVars contains `a` from the type header (the `data T a b`)+and `d` from the signature for MkT. This is done because d is used in place+of b in the result of MkT, and so we use the name d for the universal, as that+might improve error messages. On the other hand, we need to use a fresh name+for the first universal (recalling that the result of a worker must be the+type constructor applied to a sequence of plain variables), so we use `a`, from+the header. This choice of universals is made in GHC.Tc.TyCl.mkGADTVars.++Because c is not a universal, it is an existential. Here, we see that (even+ignoring order) dcUserTyVarBinders is not dcUnivTyVars ⋃ dcExTyCoVars, because+the latter has `a` while the former does not. To understand this better, let's+look at this type for the "true underlying" worker data con:++      MkT :: forall a d. forall c. (a ~# [c]) => c -> T a d++We see here that the `a` universal is connected with the `c` existential via+an equality constraint. It will always be the case (see the code in mkGADTVars)+that the universals not mentioned in dcUserTyVarBinders will be used in a+GADT equality -- that is, used on the left-hand side of an element of dcEqSpec:++  dcEqSpec = [a ~# [c]]++Putting this all together, all variables used on the left-hand side of an+equation in the dcEqSpec will be in dcUnivTyVars but *not* in+dcUserTyVarBinders.++--- Reason (R3): Kind equalities may have been solved ---++Consider now this case:++  type family F a where+    F Type = False+    F _    = True+  type T :: forall k. (F k ~ True) => k -> k -> Type+  data T a b where+    MkT :: T Maybe List++The constraint F k ~ True tells us that T does not want to be indexed by, say,+Int. Now let's consider the Core types involved:++  axiom for F: axF[0] :: F Type ~ False+               axF[1] :: forall a. F a ~ True   (a must be apart from Type)+  tycon: T :: forall k. (F k ~ True) -> k -> k -> Type+  wrapper: MkT :: T @(Type -> Type) @(Eq# (axF[1] (Type -> Type)) Maybe List+  worker:  MkT :: forall k (c :: F k ~ True) (a :: k) (b :: k).+                  (k ~# (Type -> Type), a ~# Maybe, b ~# List) =>+                  T @k @c a b++The key observation here is that the worker quantifies over c, while the wrapper+does not. The worker *must* quantify over c, because c is a universal variable,+and the result of the worker must be the type constructor applied to a sequence+of plain type variables. But the wrapper certainly does not need to quantify over+any evidence that F (Type -> Type) ~ True, as no variables are needed there.++(Aside: the c here is a regular type variable, *not* a coercion variable. This+is because F k ~ True is a *lifted* equality, not the unlifted ~#. This is why+we see Eq# in the type of the wrapper: Eq# boxes the unlifted ~# to become a+lifted ~. See also Note [The equality types story] in GHC.Builtin.Types.Prim about+Eq# and Note [Constraints in kinds] in GHC.Core.TyCo.Rep about having this constraint+in the first place.)++In this case, we'll have these fields of the DataCon:++  dcUserTyVarBinders = []    -- the wrapper quantifies over nothing+  dcUnivTyVars = [k, c, a, b]+  dcExTyCoVars = []  -- no existentials here, but a different constructor might have+  dcEqSpec = [k ~# (Type -> Type), a ~# Maybe, b ~# List]++Note that c is in the dcUserTyVars, but mentioned neither in the dcUserTyVarBinders nor+in the dcEqSpec. We thus have Reason (R3): a variable might be missing from the+dcUserTyVarBinders if its type's kind is Constraint.++(At one point, we thought that the dcEqSpec would have to be non-empty. But that+wouldn't account for silly cases like type T :: (True ~ True) => Type.)++--- End of Reasons ---++INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders+consists of:+ * The set of tyvars in dcUnivTyVars whose type variables do not appear in   dcEqSpec, unioned with:+ * The set of tyvars (*not* covars) in dcExTyCoVars   No covars here because because they're not user-written +When comparing for equality, we ignore differences concerning type variables+whose kinds have kind Constraint.+ The word "set" is used above because the order in which the tyvars appear in dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of (tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the ordering, they in fact share the same type variables (with the same Uniques). We-sometimes refer to this as "the dcUserTyVarBinders invariant".+sometimes refer to this as "the dcUserTyVarBinders invariant". It is checked+in checkDataConTyVars.  dcUserTyVarBinders, as the name suggests, is the one that users will see most of the time. It's used when computing the type signature of a@@ -767,8 +875,7 @@  -- | An 'EqSpec' is a tyvar/type pair representing an equality made in -- rejigging a GADT constructor-data EqSpec = EqSpec TyVar-                     Type+data EqSpec = EqSpec TyVar Type  -- | Make a non-dependent 'EqSpec' mkEqSpec :: TyVar -> Type -> EqSpec@@ -787,22 +894,6 @@ eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty                    | EqSpec tv ty <- spec ] --- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec--- is mapped in the substitution, it is mapped to a type variable, not--- a full type.-substEqSpec :: Subst -> EqSpec -> EqSpec-substEqSpec subst (EqSpec tv ty)-  = EqSpec tv' (substTy subst ty)-  where-    tv' = getTyVar "substEqSpec" (substTyVar subst tv)---- | Filter out any 'TyVar's mentioned in an 'EqSpec'.-filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar]-filterEqSpec eq_spec-  = filter not_in_eq_spec-  where-    not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec- instance Outputable EqSpec where   ppr (EqSpec tv ty) = ppr (tv, ty) @@ -810,20 +901,37 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that we do *not* say the worker Id is strict even if the data constructor is declared strict-     e.g.    data T = MkT !(Int,Int)-Why?  Because the *wrapper* $WMkT is strict (and its unfolding has case-expressions that do the evals) but the *worker* MkT itself is not. If we-pretend it is strict then when we see-     case x of y -> MkT y-the simplifier thinks that y is "sure to be evaluated" (because the worker MkT-is strict) and drops the case.  No, the workerId MkT is not strict.+     e.g.    data T = MkT ![Int] Bool+Even though most often the evals are done by the *wrapper* $WMkT, there are+situations in which tag inference will re-insert evals around the worker.+So for all intents and purposes the *worker* MkT is strict, too! -However, the worker does have StrictnessMarks.  When the simplifier sees a-pattern-     case e of MkT x -> ...-it uses the dataConRepStrictness of MkT to mark x as evaluated; but that's-fine... dataConRepStrictness comes from the data con not from the worker Id.+Unfortunately, if we exposed accurate strictness of DataCon workers, we'd+see the following transformation: +  f xs = case xs of xs' { __DEFAULT -> ... case MkT xs b of x { __DEFAULT -> [x] } } -- DmdAnal: Strict in xs+  ==> { drop-seq, binder swap on xs' }+  f xs = case MkT xs b of x { __DEFAULT -> [x] } -- DmdAnal: Still strict in xs+  ==> { case-to-let }+  f xs = let x = MkT xs' b in [x] -- DmdAnal: No longer strict in xs!++I.e., we are ironically losing strictness in `xs` by dropping the eval on `xs`+and then doing case-to-let. The issue is that `exprIsHNF` currently says that+every DataCon worker app is a value. The implicit assumption is that surrounding+evals will have evaluated strict fields like `xs` before! But now that we had+just dropped the eval on `xs`, that assumption is no longer valid.++Long story short: By keeping the demand signature lazy, the Simplifier will not+drop the eval on `xs` and using `exprIsHNF` to decide case-to-let and others+remains sound.++Similarly, during demand analysis in dmdTransformDataConSig, we bump up the+field demand with `C_01`, *not* `C_11`, because the latter exposes too much+strictness that will drop the eval on `xs` above.++This issue is discussed at length in+"Failed idea: no wrappers for strict data constructors" in #21497 and #22475.+ Note [Bangs on data constructor arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -884,7 +992,7 @@ Actually, the unboxed part isn't implemented yet!  Not that this representation is still *different* from runtime-representation. (Which is what STG uses afer unarise).+representation. (Which is what STG uses after unarise).  This is how T would end up being used in STG post-unarise: @@ -1047,7 +1155,7 @@           -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper           -> [KnotTied (Scaled Type)]    -- ^ Original argument types           -> KnotTied Type      -- ^ Original result type-          -> RuntimeRepInfo     -- ^ See comments on 'GHC.Core.TyCon.RuntimeRepInfo'+          -> PromDataConInfo    -- ^ See comments on 'GHC.Core.TyCon.PromDataConInfo'           -> KnotTied TyCon     -- ^ Representation type constructor           -> ConTag             -- ^ Constructor tag           -> ThetaType          -- ^ The "stupid theta", context of the data@@ -1108,8 +1216,11 @@         -- If the DataCon has a wrapper, then the worker's type is never seen         -- by the user. The visibilities we pick do not matter here.         DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $-                 mkVisFunTys rep_arg_tys $+                 mkScaledFunctionTys rep_arg_tys $                  mkTyConApp rep_tycon (mkTyVarTys univ_tvs)+                 -- res_arg_tys is a mixture of TypeLike and ConstraintLike,+                 -- so we don't know which FunTyFlag to use+                 -- Hence using mkScaledFunctionTys.        -- See Note [Promoted data constructors] in GHC.Core.TyCon     prom_tv_bndrs = [ mkNamedTyConBinder (Invisible spec) tv@@ -1119,9 +1230,9 @@       -- fresh_names: make sure that the "anonymous" tyvars don't       -- clash in name or unique with the universal/existential ones.       -- Tiresome!  And unnecessary because these tyvars are never looked at-    prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t)+    prom_theta_bndrs = [ mkInvisAnonTyConBinder (mkTyVar n t)      {- Invisible -}   | (n,t) <- fresh_names `zip` theta ]-    prom_arg_bndrs   = [ mkAnonTyConBinder VisArg (mkTyVar n t)+    prom_arg_bndrs   = [ mkAnonTyConBinder (mkTyVar n t)      {- Visible -}     | (n,t) <- dropList theta fresh_names `zip` map scaledThing orig_arg_tys ]     prom_bndrs       = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs     prom_res_kind    = orig_res_ty@@ -1208,30 +1319,6 @@ dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] dataConUserTyVarBinders = dcUserTyVarBinders --- | Equalities derived from the result type of the data constructor, as written--- by the programmer in any GADT declaration. This includes *all* GADT-like--- equalities, including those written in by hand by the programmer.-dataConEqSpec :: DataCon -> [EqSpec]-dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })-  = dataConKindEqSpec con-    ++ eq_spec ++-    [ spec   -- heterogeneous equality-    | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta-    , tc `hasKey` heqTyConKey-    , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of-                    (Just tv1, _) -> [mkEqSpec tv1 ty2]-                    (_, Just tv2) -> [mkEqSpec tv2 ty1]-                    _             -> []-    ] ++-    [ spec   -- homogeneous equality-    | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta-    , tc `hasKey` eqTyConKey-    , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of-                    (Just tv1, _) -> [mkEqSpec tv1 ty2]-                    (_, Just tv2) -> [mkEqSpec tv2 ty1]-                    _             -> []-    ]- -- | Dependent (kind-level) equalities in a constructor. -- There are extracted from the existential variables. -- See Note [Existential coercion variables]@@ -1247,7 +1334,7 @@     | cv <- ex_tcvs     , isCoVar cv     , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv-          tv = getTyVar "dataConKindEqSpec" ty1+          tv = getTyVar ty1     ]  -- | The *full* constraints on the constructor type, including dependent GADT@@ -1467,19 +1554,23 @@                              dcOrigResTy = res_ty,                              dcStupidTheta = stupid_theta })   = mkInvisForAllTys user_tvbs $-    mkInvisFunTysMany (stupid_theta ++ theta) $-    mkVisFunTys arg_tys $+    mkInvisFunTys (stupid_theta ++ theta) $+    mkScaledFunTys arg_tys $     res_ty  dataConNonlinearType :: DataCon -> Type+-- Just like dataConWrapperType, but with the+-- linearity on the arguments all zapped to Many dataConNonlinearType (MkData { dcUserTyVarBinders = user_tvbs,                                dcOtherTheta = theta, dcOrigArgTys = arg_tys,-                               dcOrigResTy = res_ty })-  = let arg_tys' = map (\(Scaled w t) -> Scaled (case w of One -> Many; _ -> w) t) arg_tys-    in mkInvisForAllTys user_tvbs $-       mkInvisFunTysMany theta $-       mkVisFunTys arg_tys' $-       res_ty+                               dcOrigResTy = res_ty,+                               dcStupidTheta = stupid_theta })+  = mkInvisForAllTys user_tvbs $+    mkInvisFunTys (stupid_theta ++ theta) $+    mkScaledFunTys arg_tys' $+    res_ty+  where+    arg_tys' = map (\(Scaled w t) -> Scaled (case w of OneTy -> ManyTy; _ -> w) t) arg_tys  dataConDisplayType :: Bool -> DataCon -> Type dataConDisplayType show_linear_types dc@@ -1595,7 +1686,7 @@                          , dcOtherTheta = theta                          , dcOrigArgTys = orig_arg_tys })   = case rep of-      NoDataConRep -> assert (null eq_spec) $ (map unrestricted theta) ++ orig_arg_tys+      NoDataConRep -> assert (null eq_spec) $ map unrestricted theta ++ orig_arg_tys       DCR { dcr_arg_tys = arg_tys } -> arg_tys  -- | The string @package:module.name@ identifying a constructor, which is attached@@ -1638,8 +1729,63 @@ -- | Is this data constructor in a "type data" declaration? -- See Note [Type data declarations] in GHC.Rename.Module. isTypeDataCon :: DataCon -> Bool-isTypeDataCon dc = isTcClsNameSpace (nameNameSpace (getName dc))+isTypeDataCon dc = isTypeDataTyCon (dataConTyCon dc) +isCovertGadtDataCon :: DataCon -> Bool+-- See Note [isCovertGadtDataCon]+isCovertGadtDataCon (MkData { dcUnivTyVars  = univ_tvs+                            , dcEqSpec     = eq_spec+                            , dcRepTyCon   = rep_tc })+  =  not (null eq_spec)                -- There are some constraints+  && not (any is_visible_spec eq_spec) -- But none of them are visible+  where+    visible_univ_tvs :: [TyVar]  -- Visible arguments in result type+    visible_univ_tvs+      = [ univ_tv | (univ_tv, tcb) <- univ_tvs `zip` tyConBinders rep_tc+                  , isVisibleTyConBinder tcb ]++    is_visible_spec :: EqSpec -> Bool+    is_visible_spec (EqSpec univ_tv ty)+       = univ_tv `elem` visible_univ_tvs+         && not (isTyVarTy ty)  -- See Note [isCovertGadtDataCon] for+                                -- an example where 'ty' is a tyvar++{- Note [isCovertGadtDataCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(isCovertGadtDataCon K) returns True if K is a GADT data constructor, but+does not /look/ like it. Consider (#21447)+    type T :: TYPE r -> Type+    data T a where { MkT :: b -> T b }+Here MkT doesn't look GADT-like, but it is. If we make the kind applications+explicit we'd see:+    data T a where { MkT :: b -> T @LiftedRep b }++The test for covert-ness is bit tricky, because we want to see if+  - dcEqSpec is non-empty+  - dcEqSpec does not constrain any of the /required/ (i.e. visible)+    arguments of the TyCon to a non-tyvar++In the example above, the DataCon for MkT will have+    dcUnivTyVars: [(r::RuntimeRep), (a :: TYPE r)]+    dcExTyVars:   [(b :: Type)]+    dcEqSpec:     [(r, LiftedRep), (a, b)]+Here+  * `r :: RuntimeRep` is constrained by dcEqSpec to LiftedRep+  * `a :: TYPE r` is constrained by dcEqSpec to `b :: Type`+But the constraint on `a` is not visible to the user, so this counts+as a covert GADT data con.  The declaration+     MkT :: forall (b :: Type). b -> T b+looks entirely non-GADT-ish.++Wrinkles:+* The visibility or otherwise is a property of the /TyCon/ binders+* The dcUnivTyVars may or may not be the same as the TyCon binders+* So we have to zip them together.+* For a data family the TyCon in question is the /representation/ TyCon+  hence dcRepTyCon+-}++ -- | Should this DataCon be allowed in a type even without -XDataKinds? -- Currently, only Lifted & Unlifted specialPromotedDc :: DataCon -> Bool@@ -1680,17 +1826,71 @@ -- -- This is not a cheap test, so we minimize its use in GHC as much as possible. -- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in--- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once+-- "MkId", and so 'dataConUserTyVarsNeedWrapper' is only called at most once -- during a data constructor's lifetime. +dataConResRepTyArgs :: DataCon -> [Type]+-- Returns the arguments of a GADT version of the /representation/ TyCon+-- Thus   data instance T [(x,y)] z where+--           MkT :: forall p q. Int -> T [(Int,p)] (Maybe q)+-- The "GADT version of the representation type" is+--        data R:T x y z where+--           MkT :: forall p q. Int -> R:T Int p (Maybe q)+-- so dataConResRepTyArgs for MkT returns [Int, p, Maybe q]+-- This is almost the same as (subst eq_spec univ_tvs); but not quite,+--   because eq_spec omits constraint-kinded equalities+dataConResRepTyArgs dc@(MkData { dcRepTyCon = rep_tc, dcOrigResTy = orig_res_ty })+  | Just (fam_tc, fam_args) <- tyConFamInst_maybe rep_tc+  = -- fvs(fam_args) = tyConTyVars rep_tc+    -- These tyvars are the domain of subst+    -- Fvs(range(subst)) = tvars of the datacon+    case  tcMatchTy (mkTyConApp fam_tc fam_args) orig_res_ty of+       Just subst -> map (substTyVar subst) (tyConTyVars rep_tc)+       Nothing    -> pprPanic "datacOnResRepTyArgs" $+                     vcat [ ppr dc, ppr fam_tc <+> ppr fam_args+                          , ppr orig_res_ty ]+  | otherwise+  = tyConAppArgs orig_res_ty++checkDataConTyVars :: DataCon -> Bool+-- Check that the worker and wrapper have the same set of type variables+-- See Note [DataCon user type variable binders]+-- Also ensures that no user tyvar is in the eq_spec (the eq_spec should+-- only relate fresh universals from (R2) of the note)+checkDataConTyVars dc@(MkData { dcUnivTyVars = univ_tvs+                              , dcExTyCoVars = ex_tvs+                              , dcEqSpec = eq_spec })+     -- use of sets here: (R1) from the Note+  = mkUnVarSet depleted_worker_vars == mkUnVarSet depleted_wrapper_vars &&+    all (not . is_eq_spec_var) wrapper_vars+  where+    is_constraint_var v = typeTypeOrConstraint (tyVarKind v) == ConstraintLike+      -- implements (R3) from the Note++    worker_vars = univ_tvs ++ ex_tvs+    eq_spec_tvs = mkUnVarSet (map eqSpecTyVar eq_spec)+    is_eq_spec_var = (`elemUnVarSet` eq_spec_tvs)  -- (R2) from the Note+    depleted_worker_vars = filterOut (is_eq_spec_var <||> is_constraint_var)+                                     worker_vars++    wrapper_vars = dataConUserTyVars dc+    depleted_wrapper_vars = filterOut is_constraint_var wrapper_vars++dataConUserTyVarsNeedWrapper :: DataCon -> Bool+-- Check whether the worker and wapper have the same type variables+-- in the same order. If not, we need a wrapper to swizzle them. -- See Note [DataCon user type variable binders], as well as -- Note [Data con wrappers and GADT syntax] for an explanation of what -- mkDataConRep is doing with this function.-dataConUserTyVarsArePermuted :: DataCon -> Bool-dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs-                                     , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec-                                     , dcUserTyVarBinders = user_tvbs }) =-  (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs+dataConUserTyVarsNeedWrapper dc@(MkData { dcUnivTyVars = univ_tvs+                                        , dcExTyCoVars = ex_tvs+                                        , dcEqSpec = eq_spec })+  = assert (null eq_spec || answer)  -- all GADTs should say "yes" here+    answer+  where+    answer = (univ_tvs ++ ex_tvs) /= dataConUserTyVars dc+              -- Worker tyvars         Wrapper tyvars+  {- %************************************************************************

@@ -27,6 +27,7 @@ dataConFullSig :: DataCon                -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) isUnboxedSumDataCon :: DataCon -> Bool+isTypeDataCon :: DataCon -> Bool  instance Eq DataCon instance Uniquable DataCon

@@ -36,7 +36,7 @@         ruleLhsFreeIds, ruleLhsFreeIdsList,         ruleRhsFreeVars, rulesRhsFreeIds, -        expr_fvs,+        exprFVs,          -- * Orphan names         orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,@@ -72,7 +72,7 @@ import GHC.Core.Coercion.Axiom import GHC.Core.FamInstEnv import GHC.Builtin.Types( unrestrictedFunTyConName )-import GHC.Builtin.Types.Prim( funTyConName )+import GHC.Builtin.Types.Prim( fUNTyCon ) import GHC.Data.Maybe( orElse )  import GHC.Utils.FV as FV@@ -349,19 +349,25 @@                 -- Look through type synonyms (#4912) orphNamesOfType (TyVarTy _)          = emptyNameSet orphNamesOfType (LitTy {})           = emptyNameSet+orphNamesOfType (ForAllTy bndr res)  = orphNamesOfType (binderType bndr)+                                       `unionNameSet` orphNamesOfType res orphNamesOfType (TyConApp tycon tys) = func                                        `unionNameSet` orphNamesOfTyCon tycon                                        `unionNameSet` orphNamesOfTypes tys         where func = case tys of-                       arg:_ | tycon == funTyCon -> orph_names_of_fun_ty_con arg+                       arg:_ | tycon == fUNTyCon -> orph_names_of_fun_ty_con arg                        _ -> emptyNameSet-orphNamesOfType (ForAllTy bndr res)  = orphNamesOfType (binderType bndr)-                                       `unionNameSet` orphNamesOfType res-orphNamesOfType (FunTy _ w arg res)  =  orph_names_of_fun_ty_con w-                                       `unionNameSet` unitNameSet funTyConName++orphNamesOfType (FunTy af w arg res) =  func+                                       `unionNameSet` unitNameSet fun_tc                                        `unionNameSet` orphNamesOfType w                                        `unionNameSet` orphNamesOfType arg                                        `unionNameSet` orphNamesOfType res+        where func | isVisibleFunArg af = orph_names_of_fun_ty_con w+                   | otherwise          = emptyNameSet++              fun_tc = tyConName (funTyFlagTyCon af)+ orphNamesOfType (AppTy fun arg)      = orphNamesOfType fun `unionNameSet` orphNamesOfType arg orphNamesOfType (CastTy ty co)       = orphNamesOfType ty `unionNameSet` orphNamesOfCo co orphNamesOfType (CoercionTy co)      = orphNamesOfCo co@@ -381,15 +387,19 @@ orphNamesOfCo (GRefl _ ty mco)      = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos orphNamesOfCo (AppCo co1 co2)       = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2-orphNamesOfCo (ForAllCo _ kind_co co)-  = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co-orphNamesOfCo (FunCo _ co_mult co1 co2) = orphNamesOfCo co_mult `unionNameSet` orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2+orphNamesOfCo (ForAllCo _ kind_co co)     = orphNamesOfCo kind_co+                                            `unionNameSet` orphNamesOfCo co+orphNamesOfCo (FunCo { fco_mult = co_mult, fco_arg = co1, fco_res = co2 })+                                    = orphNamesOfCo co_mult+                                      `unionNameSet` orphNamesOfCo co1+                                      `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (CoVarCo _)           = emptyNameSet orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos-orphNamesOfCo (UnivCo p _ t1 t2)    = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2+orphNamesOfCo (UnivCo p _ t1 t2)    = orphNamesOfProv p `unionNameSet` orphNamesOfType t1+                                      `unionNameSet` orphNamesOfType t2 orphNamesOfCo (SymCo co)            = orphNamesOfCo co orphNamesOfCo (TransCo co1 co2)     = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2-orphNamesOfCo (NthCo _ _ co)        = orphNamesOfCo co+orphNamesOfCo (SelCo _ co)          = orphNamesOfCo co orphNamesOfCo (LRCo  _ co)          = orphNamesOfCo co orphNamesOfCo (InstCo co arg)       = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg orphNamesOfCo (KindCo co)           = orphNamesOfCo co@@ -437,8 +447,8 @@ -- Detect FUN 'Many as an application of (->), so that :i (->) works as expected -- (see #8535) Issue #16475 describes a more robust solution orph_names_of_fun_ty_con :: Mult -> NameSet-orph_names_of_fun_ty_con Many = unitNameSet unrestrictedFunTyConName-orph_names_of_fun_ty_con _ = emptyNameSet+orph_names_of_fun_ty_con ManyTy = unitNameSet unrestrictedFunTyConName+orph_names_of_fun_ty_con _      = emptyNameSet  {- ************************************************************************@@ -791,3 +801,4 @@      go (Type ty)     = (tyCoVarsOfTypeDSet ty, AnnType ty)     go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)+

@@ -3,7 +3,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- (c) The University of Glasgow 2006 -- -- FamInstEnv: Type checked family instance declarations@@ -42,6 +41,7 @@ import GHC.Core.Unify import GHC.Core.Type as Type import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Compare( eqType, eqTypes ) import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Coercion.Axiom@@ -50,6 +50,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name+import GHC.Data.FastString import GHC.Data.Maybe import GHC.Types.Var import GHC.Types.SrcLoc@@ -62,6 +63,8 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.Bag+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf  {- ************************************************************************@@ -686,7 +689,7 @@     -- See Note [Tidy axioms when we build them]     -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom -    init_occ_env = initTidyOccEnv [mkTyVarOcc "_"]+    init_occ_env = initTidyOccEnv [mkTyVarOccFS (fsLit "_")]     init_tidy_env = mkEmptyTidyEnv init_occ_env     -- See Note [Always number wildcard types in CoAxBranch] @@ -1476,7 +1479,7 @@                Nothing ->                  do { ArgsReductions redns res_co                         <- normalise_args (typeKind nfun)-                                          (repeat Nominal)+                                          (Inf.repeat Nominal)                                           arg_tys                     ; role <- getRole                     ; return $@@ -1485,7 +1488,7 @@                           (mkSymMCo res_co) } }  normalise_args :: Kind    -- of the function-               -> [Role]  -- roles at which to normalise args+               -> Infinite Role  -- roles at which to normalise args                -> [Type]  -- args                -> NormM ArgsReductions -- returns ArgsReductions (Reductions cos xis) res_co,@@ -1495,7 +1498,7 @@ -- but the resulting application *will* be well-kinded -- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow normalise_args fun_ki roles args-  = do { normed_args <- zipWithM normalise1 roles args+  = do { normed_args <- zipWithM normalise1 (Inf.toList roles) args        ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args }   where     (ki_binders, inner_ki) = splitPiTys fun_ki