diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2022-11-09 10:33:22 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simon.peytonjones@gmail.com> | 2022-11-11 23:40:10 +0000 |
| commit | 778c6adca2c995cd8a1b84394d4d5ca26b915dac (patch) | |
| tree | 17350cc63ae04a5b15461771304d195c30ada2f7 /compiler | |
| parent | 154c70f6c589aa6531cbeea4aa3ec06e0acaf690 (diff) | |
| download | haskell-778c6adca2c995cd8a1b84394d4d5ca26b915dac.tar.gz | |
Type vs Constraint: finally nailed
This big patch addresses the rats-nest of issues that have plagued
us for years, about the relationship between Type and Constraint.
See #11715/#21623.
The main payload of the patch is:
* To introduce CONSTRAINT :: RuntimeRep -> Type
* To make TYPE and CONSTRAINT distinct throughout the compiler
Two overview Notes in GHC.Builtin.Types.Prim
* Note [TYPE and CONSTRAINT]
* Note [Type and Constraint are not apart]
This is the main complication.
The specifics
* New primitive types (GHC.Builtin.Types.Prim)
- CONSTRAINT
- ctArrowTyCon (=>)
- tcArrowTyCon (-=>)
- ccArrowTyCon (==>)
- funTyCon FUN -- Not new
See Note [Function type constructors and FunTy]
and Note [TYPE and CONSTRAINT]
* GHC.Builtin.Types:
- New type Constraint = CONSTRAINT LiftedRep
- I also stopped nonEmptyTyCon being built-in; it only needs to be wired-in
* Exploit the fact that Type and Constraint are distinct throughout GHC
- Get rid of tcView in favour of coreView.
- Many tcXX functions become XX functions.
e.g. tcGetCastedTyVar --> getCastedTyVar
* Kill off Note [ForAllTy and typechecker equality], in (old)
GHC.Tc.Solver.Canonical. It said that typechecker-equality should ignore
the specified/inferred distinction when comparein two ForAllTys. But
that wsa only weakly supported and (worse) implies that we need a separate
typechecker equality, different from core equality. No no no.
* GHC.Core.TyCon: kill off FunTyCon in data TyCon. There was no need for it,
and anyway now we have four of them!
* GHC.Core.TyCo.Rep: add two FunTyFlags to FunCo
See Note [FunCo] in that module.
* GHC.Core.Type. Lots and lots of changes driven by adding CONSTRAINT.
The key new function is sORTKind_maybe; most other changes are built
on top of that.
See also `funTyConAppTy_maybe` and `tyConAppFun_maybe`.
* Fix a longstanding bug in GHC.Core.Type.typeKind, and Core Lint, in
kinding ForAllTys. See new tules (FORALL1) and (FORALL2) in GHC.Core.Type.
(The bug was that before (forall (cv::t1 ~# t2). blah), where
blah::TYPE IntRep, would get kind (TYPE IntRep), but it should be
(TYPE LiftedRep). See Note [Kinding rules for types] in GHC.Core.Type.
* GHC.Core.TyCo.Compare is a new module in which we do eqType and cmpType.
Of course, no tcEqType any more.
* GHC.Core.TyCo.FVs. I moved some free-var-like function into this module:
tyConsOfType, visVarsOfType, and occCheckExpand. Refactoring only.
* GHC.Builtin.Types. Compiletely re-engineer boxingDataCon_maybe to
have one for each /RuntimeRep/, rather than one for each /Type/.
This dramatically widens the range of types we can auto-box.
See Note [Boxing constructors] in GHC.Builtin.Types
The boxing types themselves are declared in library ghc-prim:GHC.Types.
GHC.Core.Make. Re-engineer the treatment of "big" tuples (mkBigCoreVarTup
etc) GHC.Core.Make, so that it auto-boxes unboxed values and (crucially)
types of kind Constraint. That allows the desugaring for arrows to work;
it gathers up free variables (including dictionaries) into tuples.
See Note [Big tuples] in GHC.Core.Make.
There is still work to do here: #22336. But things are better than
before.
* GHC.Core.Make. 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].
* GHC.Core.TyCo.Rep. Completely refactor the NthCo coercion. It is now called
SelCo, and its fields are much more descriptive than the single Int we used to
have. A great improvement. See Note [SelCo] in GHC.Core.TyCo.Rep.
* GHC.Core.RoughMap.roughMatchTyConName. Collapse TYPE and CONSTRAINT to
a single TyCon, so that the rough-map does not distinguish them.
* GHC.Core.DataCon
- Mainly just improve documentation
* Some significant renamings:
GHC.Core.Multiplicity: Many --> ManyTy (easier to grep for)
One --> OneTy
GHC.Core.TyCo.Rep TyCoBinder --> GHC.Core.Var.PiTyBinder
GHC.Core.Var TyCoVarBinder --> ForAllTyBinder
AnonArgFlag --> FunTyFlag
ArgFlag --> ForAllTyFlag
GHC.Core.TyCon TyConTyCoBinder --> TyConPiTyBinder
Many functions are renamed in consequence
e.g. isinvisibleArgFlag becomes isInvisibleForAllTyFlag, etc
* I refactored FunTyFlag (was AnonArgFlag) into a simple, flat data type
data FunTyFlag
= FTF_T_T -- (->) Type -> Type
| FTF_T_C -- (-=>) Type -> Constraint
| FTF_C_T -- (=>) Constraint -> Type
| FTF_C_C -- (==>) Constraint -> Constraint
* GHC.Tc.Errors.Ppr. Some significant refactoring in the TypeEqMisMatch case
of pprMismatchMsg.
* I made the tyConUnique field of TyCon strict, because I
saw code with lots of silly eval's. That revealed that
GHC.Settings.Constants.mAX_SUM_SIZE can only be 63, because
we pack the sum tag into a 6-bit field. (Lurking bug squashed.)
Fixes
* #21530
Updates haddock submodule slightly.
Performance changes
~~~~~~~~~~~~~~~~~~~
I was worried that compile times would get worse, but after
some careful profiling we are down to a geometric mean 0.1%
increase in allocation (in perf/compiler). That seems fine.
There is a big runtime improvement in T10359
Metric Decrease:
LargeRecord
MultiLayerModulesTH_OneShot
T13386
T13719
Metric Increase:
T8095
Diffstat (limited to 'compiler')
171 files changed, 7216 insertions, 5827 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 26f870a5bc..1c5af5875c 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -197,7 +197,7 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon, - isPrimTyCon, isFunTyCon, + isPrimTyCon, isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, tyConClass_maybe, synTyConRhs_maybe, synTyConDefn_maybe, tyConKind, diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 26fb6c35b4..07a3bd2f9d 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -263,6 +263,7 @@ basicKnownKeyNames starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName, + constraintKindRepName, -- WithDict withDictClassName, @@ -338,6 +339,9 @@ basicKnownKeyNames fromListNName, toListName, + -- Non-empty lists + nonEmptyTyConName, + -- Overloaded record dot, record update getFieldName, setFieldName, @@ -1406,14 +1410,19 @@ typeCharTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeCharTypeRep") type 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 @@ -1788,7 +1797,7 @@ hasFieldClassNameKey = mkPreludeClassUnique 50 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, @@ -1799,7 +1808,8 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, 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 @@ -1811,7 +1821,7 @@ doublePrimTyConKey = mkPreludeTyConUnique 9 doubleTyConKey = mkPreludeTyConUnique 10 floatPrimTyConKey = mkPreludeTyConUnique 11 floatTyConKey = mkPreludeTyConUnique 12 -funTyConKey = mkPreludeTyConUnique 13 +fUNTyConKey = mkPreludeTyConUnique 13 intPrimTyConKey = mkPreludeTyConUnique 14 intTyConKey = mkPreludeTyConUnique 15 int8PrimTyConKey = mkPreludeTyConUnique 16 @@ -1842,6 +1852,10 @@ stablePtrTyConKey = mkPreludeTyConUnique 39 eqTyConKey = mkPreludeTyConUnique 40 heqTyConKey = mkPreludeTyConUnique 41 +ctArrowTyConKey = mkPreludeTyConUnique 42 +ccArrowTyConKey = mkPreludeTyConUnique 43 +tcArrowTyConKey = mkPreludeTyConUnique 44 + statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, @@ -1892,16 +1906,21 @@ voidTyConKey = mkPreludeTyConUnique 85 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 @@ -1923,7 +1942,6 @@ trNameTyConKey = mkPreludeTyConUnique 106 kindRepTyConKey = mkPreludeTyConUnique 107 typeLitSortTyConKey = mkPreludeTyConUnique 108 - -- Generics (Unique keys) v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, @@ -2072,8 +2090,7 @@ charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, 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 @@ -2092,7 +2109,6 @@ trueDataConKey = mkPreludeDataConUnique 14 wordDataConKey = mkPreludeDataConUnique 15 ioDataConKey = mkPreludeDataConUnique 16 heqDataConKey = mkPreludeDataConUnique 18 -nonEmptyDataConKey = mkPreludeDataConUnique 19 -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique @@ -2110,7 +2126,10 @@ ordLTDataConKey = mkPreludeDataConUnique 27 ordEQDataConKey = mkPreludeDataConUnique 28 ordGTDataConKey = mkPreludeDataConUnique 29 +mkDictDataConKey :: Unique +mkDictDataConKey = mkPreludeDataConUnique 30 +coercibleDataConKey :: Unique coercibleDataConKey = mkPreludeDataConUnique 32 staticPtrDataConKey :: Unique @@ -2254,7 +2273,7 @@ naturalNBDataConKey = mkPreludeDataConUnique 124 ************************************************************************ -} -wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, +wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey, buildIdKey, foldrIdKey, recSelErrorIdKey, seqIdKey, eqStringIdKey, noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, @@ -2271,6 +2290,7 @@ absentErrorIdKey = mkPreludeMiscIdUnique 1 augmentIdKey = mkPreludeMiscIdUnique 2 appendIdKey = mkPreludeMiscIdUnique 3 buildIdKey = mkPreludeMiscIdUnique 4 +absentConstraintErrorIdKey = mkPreludeMiscIdUnique 5 foldrIdKey = mkPreludeMiscIdUnique 6 recSelErrorIdKey = mkPreludeMiscIdUnique 7 seqIdKey = mkPreludeMiscIdUnique 8 @@ -2335,7 +2355,7 @@ traceKey = mkPreludeMiscIdUnique 108 nospecIdKey :: Unique nospecIdKey = mkPreludeMiscIdUnique 109 -inlineIdKey, noinlineIdKey :: Unique +inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique inlineIdKey = mkPreludeMiscIdUnique 120 -- see below @@ -2343,8 +2363,9 @@ mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique 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 @@ -2484,14 +2505,15 @@ tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 515 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 @@ -2785,9 +2807,10 @@ pretendNameIsInScope n [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey , liftedDataConKey, unliftedDataConKey , tYPETyConKey + , cONSTRAINTTyConKey , runtimeRepTyConKey, boxedRepDataConKey , eqTyConKey , listTyConKey , oneDataConKey , manyDataConKey - , funTyConKey ] + , fUNTyConKey, unrestrictedFunTyConKey ] diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 85bdd334c9..5e59c30884 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -34,7 +34,7 @@ module GHC.Builtin.Types ( promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, -- * Boxing primitive types - boxingDataCon_maybe, + boxingDataCon, BoxingInfo(..), -- * Char charTyCon, charDataCon, charTyCon_RDR, @@ -63,10 +63,6 @@ module GHC.Builtin.Types ( promotedNilDataCon, promotedConsDataCon, mkListTy, mkPromotedListTy, - -- * NonEmpty - nonEmptyTyCon, nonEmptyTyConName, - nonEmptyDataCon, nonEmptyDataConName, - -- * Maybe maybeTyCon, maybeTyConName, nothingDataCon, nothingDataConName, promotedNothingDataCon, @@ -83,7 +79,7 @@ module GHC.Builtin.Types ( unboxedUnitTy, unboxedUnitTyCon, unboxedUnitDataCon, unboxedTupleKind, unboxedSumKind, - filterCTuple, + filterCTuple, mkConstraintTupleTy, -- ** Constraint tuples cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName, @@ -105,6 +101,8 @@ module GHC.Builtin.Types ( isLiftedTypeKindTyConName, typeToTypeKind, liftedRepTyCon, unliftedRepTyCon, + tYPETyCon, tYPETyConName, tYPEKind, + cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind, constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon, constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName, @@ -116,15 +114,17 @@ module GHC.Builtin.Types ( 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.Types.Prim 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 ) @@ -274,7 +279,8 @@ names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc -- 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 +324,6 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they , unliftedRepTyCon , zeroBitRepTyCon , zeroBitTypeTyCon - , nonEmptyTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -377,10 +382,6 @@ listTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "List") 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,80 +510,6 @@ makeRecoveryTyCon tc 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 @@ -609,7 +536,7 @@ consDataCon_RDR = nameRdrName consDataConName 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 +546,41 @@ pcTyCon name cType tyvars cons 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 +588,9 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (n -- 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 +602,7 @@ pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo -- 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 +618,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars (mkTyVarBinders SpecifiedSpec user_tyvars) [] -- No equality spec - [] -- No theta + theta arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) rri tycon @@ -700,16 +644,11 @@ mkDataConWorkerName data_con wrk_key = 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,13 +660,6 @@ typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] 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 +800,7 @@ isBuiltInOcc_maybe occ = ":" -> Just consDataConName -- function tycon - "FUN" -> Just funTyConName + "FUN" -> Just fUNTyConName "->" -> Just unrestrictedFunTyConName -- boxed tuple data/tycon @@ -1162,7 +1094,7 @@ mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr) (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 +1152,6 @@ unboxedUnitTyCon = tupleTyCon Unboxed 0 unboxedUnitDataCon :: DataCon unboxedUnitDataCon = tupleDataCon Unboxed 0 - {- ********************************************************************* * * Unboxed sums @@ -1349,7 +1280,7 @@ eqSCSelId, heqSCSelId, coercibleSCSelId :: Id 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 +1298,7 @@ eqSCSelId, heqSCSelId, coercibleSCSelId :: Id 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 +1316,7 @@ eqSCSelId, heqSCSelId, coercibleSCSelId :: Id 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 +1350,20 @@ mk_ctuple_class tycon sc_theta sc_sel_ids 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 +1389,21 @@ multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing 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,84 +1414,82 @@ unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "-> * * 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 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 ('BoxedRep 'Lifted)@ +-- 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 - {- ********************************************************************* * * @@ -1558,6 +1497,11 @@ zeroBitRepTy = mkTyConTy zeroBitRepTyCon * * ********************************************************************* -} +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 +1510,9 @@ levityTy = mkTyConTy levityTyCon 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 +1552,35 @@ See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. 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 +1589,6 @@ boxedRepDataCon = pcSpecialDataCon boxedRepDataConName 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) @@ -1685,18 +1626,27 @@ sumRepDataConTyCon = promoteDataCon sumRepDataCon -- 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,6 +1664,114 @@ intRepDataConTy, ] = 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 + +-- See Note [Wiring in RuntimeRep] +vecCountDataConNames :: [Name] +vecCountDataConNames = zipWith3Lazy mk_runtime_rep_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_runtime_rep_dc_name + [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" + , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep" + , fsLit "Word32ElemRep", fsLit "Word64ElemRep" + , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] + vecElemDataConKeys + vecElemDataCons + +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 @@ -1763,30 +1821,6 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, * * ********************************************************************* -} -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 +1897,140 @@ doubleTyCon = pcTyCon doubleTyConName 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 +2137,14 @@ nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon 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 +2234,7 @@ mkTupleTy boxity tys = mkTupleTy1 boxity tys 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]. @@ -2085,6 +2244,18 @@ mkBoxedTupleTy tys = mkTupleTy Boxed tys 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 + + {- ********************************************************************* * * The sum types diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot index 3149e1f55b..b066283ffe 100644 --- a/compiler/GHC/Builtin/Types.hs-boot +++ b/compiler/GHC/Builtin/Types.hs-boot @@ -16,8 +16,8 @@ coercibleTyCon, heqTyCon :: TyCon unitTy :: Type - liftedTypeKindTyConName :: Name +constraintKindTyConName :: Name liftedTypeKind, unliftedTypeKind, zeroBitTypeKind :: Kind diff --git a/compiler/GHC/Builtin/Types/Literals.hs b/compiler/GHC/Builtin/Types/Literals.hs index 273d084c96..02ffbd31dd 100644 --- a/compiler/GHC/Builtin/Types/Literals.hs +++ b/compiler/GHC/Builtin/Types/Literals.hs @@ -29,12 +29,12 @@ import GHC.Prelude import GHC.Core.Type import GHC.Data.Pair -import GHC.Tc.Utils.TcType ( TcType, tcEqType ) import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon , Injectivity(..) ) import GHC.Core.Coercion ( Role(..) ) import GHC.Tc.Types.Constraint ( Xi ) import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) +import GHC.Core.TyCo.Compare ( tcEqType ) import GHC.Types.Name ( Name, BuiltInSyntax(..) ) import GHC.Types.Unique.FM import GHC.Builtin.Types @@ -630,7 +630,7 @@ isOrderingLitTy tc = | tc1 == promotedGTDataCon -> return GT | otherwise -> Nothing -known :: (Integer -> Bool) -> TcType -> Bool +known :: (Integer -> Bool) -> Type -> Bool known p x = case isNumLitTy x of Just a -> p a Nothing -> False diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 83d36af673..0335e1cb11 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -30,6 +30,8 @@ module GHC.Builtin.Types.Prim( levity1TyVarInf, levity2TyVarInf, levity1Ty, levity2Ty, + alphaConstraintTyVar, alphaConstraintTy, + openAlphaTyVar, openBetaTyVar, openGammaTyVar, openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec, openAlphaTy, openBetaTy, openGammaTy, @@ -41,13 +43,16 @@ module GHC.Builtin.Types.Prim( 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 @@ import {-# SOURCE #-} GHC.Builtin.Types , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy , doubleElemRepDataConTy - , multiplicityTy ) + , multiplicityTy + , constraintKind ) + +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 +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 @@ exposedPrimTyCons , 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, @@ -273,13 +353,13 @@ weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPr 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", ... ] -} @@ -366,13 +446,16 @@ mkTemplateKiTyVar kind mk_arg_kinds 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 @@ -383,6 +466,15 @@ alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar 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 @@ -416,7 +508,9 @@ openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar -- 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 @@ -445,8 +539,8 @@ levity2Ty = mkTyVarTy levity2TyVar 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) @@ -471,80 +565,280 @@ multiplicityTyVar1, multiplicityTyVar2 :: TyVar ************************************************************************ -} -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. + +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. - data RuntimeRep -- Defined in ghc-prim:GHC.Types +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 - -The 'rr' parameter tells us how the value is represented at runtime. - -Generally speaking, you can't be polymorphic in 'rr'. E.g + Eq Int :: CONSTRAINT (BoxedRep Lifted) + IP "foo" Int :: CONSTRAINT (BoxedRep Lifted) + a ~ b :: CONSTRAINT (BoxedRep Lifted) + a ~# b :: CONSTRAINT (TupleRep []) + +Constraints are mostly lifted, but unlifted ones are useful too. +Specifically (a ~# b) :: CONSTRAINT (TupleRep []) + +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 @@ -569,85 +863,40 @@ generator never has to manipulate a value of type 'a :: TYPE rr'. (#,#) :: 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 @@ -818,6 +1067,8 @@ It is an almost-ordinary class defined as if by * 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 @@ -944,9 +1195,9 @@ eqPrimTyCon :: TyCon -- The representation type for equality predicates -- 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 @@ -955,9 +1206,9 @@ eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles 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. @@ -966,9 +1217,9 @@ eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles 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? diff --git a/compiler/GHC/Builtin/Types/Prim.hs-boot b/compiler/GHC/Builtin/Types/Prim.hs-boot deleted file mode 100644 index 28326fcc8b..0000000000 --- a/compiler/GHC/Builtin/Types/Prim.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module GHC.Builtin.Types.Prim where - -import GHC.Core.TyCon - -tYPETyCon :: TyCon diff --git a/compiler/GHC/Builtin/Uniques.hs b/compiler/GHC/Builtin/Uniques.hs index e689ca6304..9da937f8c5 100644 --- a/compiler/GHC/Builtin/Uniques.hs +++ b/compiler/GHC/Builtin/Uniques.hs @@ -13,8 +13,8 @@ module GHC.Builtin.Uniques -- * Getting the 'Unique's of 'Name's -- ** Anonymous sums - , mkSumTyConUnique - , mkSumDataConUnique + , mkSumTyConUnique, mkSumDataConUnique + -- ** Tuples -- *** Vanilla , mkTupleTyConUnique @@ -45,6 +45,9 @@ module GHC.Builtin.Uniques , initExitJoinUnique + -- Boxing data types + , mkBoxingTyConUnique, boxingDataConUnique + ) where import GHC.Prelude @@ -60,7 +63,6 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Maybe @@ -107,8 +109,9 @@ TypeRep for sum DataCon of arity k and alternative n (zero-based): 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 @@ Allocation of unique supply characters: 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 @@ Allocation of unique supply characters: 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 @@ mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) 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 diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index ad4e1b4ada..71c2d075ed 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -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 @@ module GHC.Core.Coercion ( 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,15 +60,13 @@ module GHC.Core.Coercion ( 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, - tyConRoleListX, tyConRoleListRepresentational, - + tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, + tyConRoleListX, tyConRoleListRepresentational, funRole, pickLR, isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, @@ -119,7 +121,7 @@ module GHC.Core.Coercion ( -- * Other promoteCoercion, buildCoercion, - multToCo, + multToCo, mkRuntimeRepCo, hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy, @@ -136,11 +138,11 @@ import GHC.Core.TyCo.FVs 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 @@ -249,7 +251,7 @@ ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) -> 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 ] @@ -363,9 +365,9 @@ mkPiMCos :: [Var] -> MCoercion -> MCoercion 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 @@ -390,22 +392,8 @@ isReflMCo _ = False 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: -- @@ -414,22 +402,25 @@ decomposeCo :: Arity -> Coercion -> Infinite Role -- the roles of the output coercions -> [Coercion] decomposeCo arity co rs - = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` Inf.toList 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" - -decomposeFunCo _ (FunCo _ w co1 co2) = (w, co1, co2) - -- Short-circuits the calls to mkNthCo - -decomposeFunCo r co = assertPpr all_ok (ppr co) - (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co) +-- 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 { fco_mult = w, fco_arg = co1, fco_res = co2 }) + = (w, co1, co2) + -- Short-circuits the calls to mkSelCo + +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 @@ -490,24 +481,25 @@ decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args -- 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 @@ -528,19 +520,6 @@ getCoVar_maybe :: Coercion -> Maybe CoVar 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 (tyConRoleListX 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 @@ -553,10 +532,10 @@ splitAppCo_maybe (TyConAppCo r tc args) , 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 @@ -569,7 +548,7 @@ splitAppCo_maybe _ = Nothing -- 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) @@ -630,13 +609,13 @@ eqTyConRole tc = 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) @@ -709,7 +688,6 @@ of Coercion, and they perform very basic optimizations. Note [Role twiddling functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - There are a plethora of functions for twiddling roles: mkSubCo: Requires a nominal input coercion and always produces a @@ -775,14 +753,10 @@ mkNomReflCo = Refl -- 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 - - -- Expand type synonyms + | Just co <- tyConAppFunCo_maybe r tc cos + = co + + -- 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 @@ -792,17 +766,85 @@ mkTyConAppCo r tc cos | 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. @@ -900,11 +942,11 @@ mkForAllCo v kind_co co 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 @@ -1065,139 +1107,84 @@ mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) = 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 +mkSelCo n co = mkSelCo_maybe n co `orElse` SelCo n co + +mkSelCo_maybe :: HasDebugCallStack + => CoSel -> Coercion -mkNthCo r n co - = assertPpr good_call bad_call_msg $ - go n co + -> 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 0 (ForAllCo _ kind_co _) - = assert (r == Nominal) - kind_co + go cs co + | Just (ty, r) <- isReflCo_maybe co + = Just (mkReflCo r (getNthFromType cs ty)) + + 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 = r == nthRole (coercionRole co) tc1 n - in len1 == len2 && n < len1 && good_role + = True - | otherwise - = True + good_call (SelFun {}) + = isFunTy ty1 && isFunTy ty2 --- | 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) - --- | 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 - - | 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 @@ -1207,7 +1194,7 @@ mkLRCo lr co = 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 @@ -1223,7 +1210,7 @@ mkGReflRightCo r ty co -- 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 @@ -1275,10 +1262,10 @@ mkSubCo (Refl ty) = GRefl Representational ty MRefl 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,10 +1335,11 @@ setNominalRole_maybe r co setNominalRole_maybe_helper (TyConAppCo 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 @@ -1361,10 +1349,10 @@ setNominalRole_maybe r co = 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,7 +1380,7 @@ toPhantomCo co applyRoles :: TyCon -> [Coercion] -> [Coercion] 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) @@ -1413,10 +1401,20 @@ tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal tyConRoleListRepresentational :: TyCon -> [Role] tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational -nthRole :: Role -> TyCon -> Int -> Role -nthRole Nominal _ _ = Nominal -nthRole Phantom _ _ = Phantom -nthRole Representational tc n = tyConRolesRepresentational tc Inf.!! n +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? @@ -1436,20 +1434,18 @@ promoteCoercion :: Coercion -> CoercionN -- 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' @@ -1467,14 +1463,19 @@ promoteCoercion co = case co of | 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 @@ -1492,14 +1493,9 @@ promoteCoercion co = case co of 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 @@ -1523,7 +1519,7 @@ promoteCoercion co = case co of -- 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 @@ -1551,10 +1547,12 @@ instCoercion (Pair lty rty) g w -- 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 @@ -1623,17 +1621,18 @@ mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co -- 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 @@ -1839,7 +1838,7 @@ The KPUSH rule deals with this situation 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 @@ -1856,7 +1855,7 @@ available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf 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 @@ -1864,7 +1863,7 @@ Consider we have datatype 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. @@ -2031,14 +2030,14 @@ ty_co_subst !lc role ty = 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 (tyConRoleListX 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 @@ -2196,8 +2195,8 @@ liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var 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 @@ -2289,7 +2288,8 @@ seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos 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 @@ -2297,7 +2297,7 @@ seqCo (UnivCo p r t1 t2) = 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 @@ -2348,25 +2348,27 @@ coercionLKind :: Coercion -> Type 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 @@ -2386,42 +2388,48 @@ coercionLKind co 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) @@ -2463,10 +2471,11 @@ coercionRKind co | 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 @@ -2513,14 +2522,16 @@ coercionRole = go 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 @@ -2614,20 +2625,21 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 ; _ -> 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) @@ -2655,8 +2667,8 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 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 diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot index cbc40e2a13..5d5193306e 100644 --- a/compiler/GHC/Core/Coercion.hs-boot +++ b/compiler/GHC/Core/Coercion.hs-boot @@ -17,14 +17,16 @@ mkReflCo :: Role -> Type -> Coercion 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 diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index d061d795a7..6e10eae9e2 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -15,6 +15,7 @@ import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType ) 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.Core.Unify 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 ) @@ -122,8 +124,19 @@ optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo -- ^ 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 @@ -135,19 +148,23 @@ optCoercion' env co 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 @@ -190,9 +207,12 @@ opt_co3 env sym _ r co = opt_co4_wrap env sym False r co -- 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 {" @@ -200,12 +220,13 @@ opt_co4_wrap env sym rep r co , 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 $$ @@ -268,15 +289,17 @@ opt_co4 env sym rep r (ForAllCo tv k_co co) 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 @@ -332,38 +355,29 @@ opt_co4 env sym rep r (TransCo co1 co2) 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 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_wrap env sym rep Nominal 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 @@ -371,7 +385,7 @@ opt_co4 env sym rep r (NthCo _r n co) else nth_co | otherwise - = wrapRole rep r $ NthCo r n co' + = wrapRole rep r $ SelCo n co' where co' = opt_co1 env sym co @@ -454,8 +468,8 @@ opt_co4 env sym rep r (InstCo co1 arg) -- 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)) @@ -576,9 +590,9 @@ opt_univ env sym prov role oty1 oty2 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 @@ -650,13 +664,12 @@ opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) 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 @@ -693,10 +706,14 @@ opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2 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] @@ -771,8 +788,8 @@ opt_trans_rule is co1 co2 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 @@ -1133,9 +1150,9 @@ Similarly, we do this 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) @@ -1147,7 +1164,7 @@ etaForAllCo_ty_maybe co | 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)) @@ -1163,13 +1180,13 @@ etaForAllCo_co_maybe co | 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)) @@ -1196,17 +1213,19 @@ etaAppCo_maybe co 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 diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs index 60f76fb302..f1b147c972 100644 --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -185,10 +185,14 @@ conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys -- -- 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 diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 70aa2b8b75..2846fa7b33 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -20,7 +20,6 @@ module GHC.Core.DataCon ( -- ** Equality specs EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, eqSpecPair, eqSpecPreds, - substEqSpec, filterEqSpec, -- ** Field labels FieldLabel(..), FieldLabelString, @@ -37,11 +36,11 @@ module GHC.Core.DataCon ( 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 @@ module GHC.Core.DataCon ( -- ** 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.Coercion 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.Utils.Binary 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 @@ data DataCon -- 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 @@ data DataCon -- 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 @@ For the TyVarBinders in a DataCon and PatSyn: * 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 @@ order in which TyVarBinders appear in a DataCon. 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 @@ but dcRepArity does. For example: 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 @@ according to the rules of TypeApplications, in the absence of `forall` GHC 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. + +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.) -This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders -consists precisely of: +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 @@ data StrictnessMark = MarkedStrict | NotMarkedStrict -- | 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 :: [EqSpec] -> ThetaType 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) @@ -884,7 +975,7 @@ but the rep type is 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 +1138,7 @@ mkDataCon :: Name -> 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 +1199,11 @@ mkDataCon name declared_infix prom_info -- 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 +1213,9 @@ mkDataCon name declared_infix prom_info -- 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 +1302,6 @@ dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs 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 +1317,7 @@ dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) | 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,18 +1537,18 @@ dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs, 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 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 + = let arg_tys' = map (\(Scaled w t) -> Scaled (case w of OneTy -> ManyTy; _ -> w) t) arg_tys in mkInvisForAllTys user_tvbs $ - mkInvisFunTysMany theta $ - mkVisFunTys arg_tys' $ + mkInvisFunTys theta $ + mkScaledFunTys arg_tys' $ res_ty dataConDisplayType :: Bool -> DataCon -> Type @@ -1595,7 +1665,7 @@ dataConRepArgTys (MkData { dcRep = rep , 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 @@ -1640,6 +1710,61 @@ isNewDataCon dc = isNewTyCon (dataConTyCon dc) isTypeDataCon :: DataCon -> Bool 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 +1805,71 @@ dataConCannotMatch tys con -- -- 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 + {- %************************************************************************ diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index 1565af9f56..6451eab75e 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -72,7 +72,7 @@ import GHC.Core.TyCon 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 @@ orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty' -- 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 (Refl ty) = orphNamesOfType ty 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 @@ orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) -- 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 @@ freeVars = go go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) + diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 5ecb83d4a6..9bc4297af2 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -42,6 +42,7 @@ import GHC.Prelude 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 diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index 9b9fd995a2..bb7315074f 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -38,15 +38,16 @@ import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker, -- and depends on TcType in many ways import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) import GHC.Core.RoughMap +import GHC.Core.Class +import GHC.Core.Unify + import GHC.Unit.Module.Env import GHC.Unit.Types -import GHC.Core.Class import GHC.Types.Var import GHC.Types.Unique.DSet import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Set -import GHC.Core.Unify import GHC.Types.Basic import GHC.Types.Id import Data.Data ( Data ) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 6c285db819..ea443e3b91 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -49,9 +49,10 @@ import GHC.Core.Type as Type import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Core.TyCo.Rep -- checks validity of types/coercions +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCo.Subst import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars ) +import GHC.Core.TyCo.Ppr import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify @@ -166,9 +167,10 @@ If we have done specialisation the we check that there are Note [Linting function types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in Note [Representation of function types], all saturated -applications of funTyCon are represented with the FunTy constructor. We check -this invariant in lintType. +All saturated applications of funTyCon are represented with the FunTy constructor. +See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim + + We check this invariant in lintType. Note [Linting type lets] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -924,7 +926,7 @@ lintCoreExpr e@(Let (Rec pairs) body) ; ((body_type, body_ue), ues) <- lintRecBindings NotTopLevel pairs $ \ bndrs' -> lintLetBody bndrs' body - ; return (body_type, body_ue `addUE` scaleUE Many (foldr1 addUE ues)) } + ; return (body_type, body_ue `addUE` scaleUE ManyTy (foldr1 addUE ues)) } where bndrs = map fst pairs @@ -1404,7 +1406,7 @@ lintTyApp fun_ty arg_ty -- application. lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv) lintValApp arg fun_ty arg_ty fun_ue arg_ue - | Just (w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty + | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) ; let app_ue = addUE fun_ue (scaleUE w arg_ue) ; return (res_ty', app_ue) } @@ -1566,8 +1568,8 @@ lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rh -- We've already check lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys - ; binderMult (Named _) = Many - ; binderMult (Anon _ st) = scaledMult st + ; binderMult (Named _) = ManyTy + ; binderMult (Anon st _) = scaledMult st -- See Note [Validating multiplicities in a case] ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty } @@ -1636,19 +1638,25 @@ lintBinder site var linterF lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a lintTyBndr = lintTyCoBndr -- We could specialise it, I guess --- lintCoBndr :: CoVar -> (LintedTyCoVar -> LintM a) -> LintM a --- lintCoBndr = lintTyCoBndr -- We could specialise it, I guess - lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a lintTyCoBndr tcv thing_inside = do { subst <- getSubst - ; kind' <- lintType (varType tcv) + ; tcv_type' <- lintType (varType tcv) ; let tcv' = uniqAway (getSubstInScope subst) $ - setVarType tcv kind' + setVarType tcv tcv_type' subst' = extendTCvSubstWithClone subst tcv tcv' - ; when (isCoVar tcv) $ - lintL (isCoVarType kind') - (text "CoVar with non-coercion type:" <+> pprTyVar tcv) + + -- See (FORALL1) and (FORALL2) in GHC.Core.Type + ; if (isTyVar tcv) + then -- Check that in (forall (a:ki). blah) we have ki:Type + lintL (isLiftedTypeKind (typeKind tcv_type')) $ + hang (text "TyVar whose kind does not have kind Type:") + 2 (ppr tcv' <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr (typeKind tcv_type')) + else -- Check that in (forall (cv::ty). blah), + -- then ty looks like (t1 ~# t2) + lintL (isCoVarType tcv_type') $ + text "CoVar with non-coercion type:" <+> pprTyVar tcv + ; updateSubst subst' (thing_inside tcv') } lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a @@ -1730,7 +1738,7 @@ lintValueType ty = addLoc (InType ty) $ do { ty' <- lintType ty ; let sk = typeKind ty' - ; lintL (classifiesTypeWithValues sk) $ + ; lintL (isTYPEorCONSTRAINT sk) $ hang (text "Ill-kinded type:" <+> ppr ty) 2 (text "has kind:" <+> ppr sk) ; return ty' } @@ -1778,13 +1786,11 @@ lintType ty@(TyConApp tc tys) = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags ; lintTySynFamApp report_unsat ty tc tys } - | isFunTyCon tc - , tys `lengthIs` 5 + | Just {} <- tyConAppFunTy_maybe tc tys -- We should never see a saturated application of funTyCon; such -- applications should be represented with the FunTy constructor. - -- See Note [Linting function types] and - -- Note [Representation of function types]. - = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty)) + -- See Note [Linting function types] + = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) 2 (ppr ty)) | otherwise -- Data types, data families, primitive types = do { checkTyCon tc @@ -1799,6 +1805,12 @@ lintType ty@(FunTy af tw t1 t2) ; t2' <- lintType t2 ; tw' <- lintType tw ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' tw' + ; let real_af = chooseFunTyFlag t1 t2 + ; unless (real_af == af) $ addErrL $ + hang (text "Bad FunTyFlag in FunTy") + 2 (vcat [ ppr ty + , text "FunTyFlag =" <+> ppr af + , text "Computed FunTyFlag =" <+> ppr real_af ]) ; return (FunTy af tw' t1' t2') } lintType ty@(ForAllTy (Bndr tcv vis) body_ty) @@ -1887,7 +1899,7 @@ lintTySynFamApp report_unsat ty tc tys -- Confirms that a type is really TYPE r or Constraint checkValueType :: LintedType -> SDoc -> LintM () checkValueType ty doc - = lintL (classifiesTypeWithValues kind) + = lintL (isTYPEorCONSTRAINT kind) (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$ text "when checking" <+> doc) where @@ -1899,17 +1911,16 @@ lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM () -- See Note [GHC Formalism] lintArrow what t1 t2 tw -- Eg lintArrow "type or kind `blah'" k1 k2 kw -- or lintArrow "coercion `blah'" k1 k2 kw - = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1)) - ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) - ; unless (isMultiplicityTy kw) (addErrL (msg (text "multiplicity") kw)) } + = do { unless (isTYPEorCONSTRAINT k1) (report (text "argument") k1) + ; unless (isTYPEorCONSTRAINT k2) (report (text "result") k2) + ; unless (isMultiplicityTy kw) (report (text "multiplicity") kw) } where k1 = typeKind t1 k2 = typeKind t2 kw = typeKind tw - msg ar k - = vcat [ hang (text "Ill-kinded" <+> ar) - 2 (text "in" <+> what) - , what <+> text "kind:" <+> ppr k ] + report ar k = addErrL (vcat [ hang (text "Ill-kinded" <+> ar) + 2 (text "in" <+> what) + , what <+> text "kind:" <+> ppr k ]) ----------------- lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM () @@ -2094,7 +2105,7 @@ that returned coercion. If we get long chains, that can be asymptotically inefficient, notably in * TransCo * InstCo -* NthCo (cf #9233) +* SelCo (cf #9233) * LRCo But the code is simple. And this is only Lint. Let's wait to see if @@ -2163,9 +2174,9 @@ lintCoercion (GRefl r ty (MCo co)) ; return (GRefl r ty' (MCo co')) } lintCoercion co@(TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [_w, _rep1,_rep2,_co1,_co2] <- cos - = failWithL (text "Saturated TyConAppCo (->):" <+> ppr co) + | Just {} <- tyConAppFunCo_maybe r tc cos + = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) + 2 (ppr co)) -- All saturated TyConAppCos should be FunCos | Just {} <- synTyConDefn_maybe tc @@ -2231,24 +2242,33 @@ lintCoercion co@(ForAllCo tcv kind_co body_co) ; return (ForAllCo tcv' kind_co' body_co') } } -lintCoercion co@(FunCo r cow co1 co2) +lintCoercion co@(FunCo { fco_role = r, fco_afl = afl, fco_afr = afr + , fco_mult = cow, fco_arg = co1, fco_res = co2 }) = do { co1' <- lintCoercion co1 ; co2' <- lintCoercion co2 ; cow' <- lintCoercion cow ; let Pair lt1 rt1 = coercionKind co1 Pair lt2 rt2 = coercionKind co2 Pair ltw rtw = coercionKind cow - ; lintArrow (text "coercion" <+> quotes (ppr co)) lt1 lt2 ltw - ; lintArrow (text "coercion" <+> quotes (ppr co)) rt1 rt2 rtw + ; lintL (afl == chooseFunTyFlag lt1 lt2) (bad_co_msg "afl") + ; lintL (afr == chooseFunTyFlag rt1 rt2) (bad_co_msg "afr") + ; lintArrow (bad_co_msg "arrowl") lt1 lt2 ltw + ; lintArrow (bad_co_msg "arrowr") rt1 rt2 rtw ; lintRole co1 r (coercionRole co1) ; lintRole co2 r (coercionRole co2) - ; ensureEqTys (typeKind ltw) multiplicityTy (text "coercion" <> quotes (ppr co)) - ; ensureEqTys (typeKind rtw) multiplicityTy (text "coercion" <> quotes (ppr co)) + ; ensureEqTys (typeKind ltw) multiplicityTy (bad_co_msg "mult-l") + ; ensureEqTys (typeKind rtw) multiplicityTy (bad_co_msg "mult-r") ; let expected_mult_role = case r of Phantom -> Phantom _ -> Nominal ; lintRole cow expected_mult_role (coercionRole cow) - ; return (FunCo r cow' co1' co2') } + ; return (co { fco_mult = cow', fco_arg = co1', fco_res = co2' }) } + where + bad_co_msg s = hang (text "Bad coercion" <+> parens (text s)) + 2 (vcat [ text "afl:" <+> ppr afl + , text "afr:" <+> ppr afr + , text "arg_co:" <+> ppr co1 + , text "res_co:" <+> ppr co2 ]) -- See Note [Bad unsafe coercion] lintCoercion co@(UnivCo prov r ty1 ty2) @@ -2258,8 +2278,8 @@ lintCoercion co@(UnivCo prov r ty1 ty2) k2 = typeKind ty2' ; prov' <- lint_prov k1 k2 prov - ; when (r /= Phantom && classifiesTypeWithValues k1 - && classifiesTypeWithValues k2) + ; when (r /= Phantom && isTYPEorCONSTRAINT k1 + && isTYPEorCONSTRAINT k2) (checkTypes ty1 ty2) ; return (UnivCo prov' r ty1' ty2') } @@ -2352,32 +2372,39 @@ lintCoercion co@(TransCo co1 co2) ; lintRole co (coercionRole co1) (coercionRole co2) ; return (TransCo co1' co2') } -lintCoercion the_co@(NthCo r0 n co) +lintCoercion the_co@(SelCo cs co) = do { co' <- lintCoercion co - ; let (Pair s t, r) = coercionKindRole co' - ; case (splitForAllTyCoVar_maybe s, splitForAllTyCoVar_maybe t) of - { (Just _, Just _) - -- works for both tyvar and covar - | n == 0 - , (isForAllTy_ty s && isForAllTy_ty t) + ; let (Pair s t, co_role) = coercionKindRole co' + + ; if -- forall (both TyVar and CoVar) + | Just _ <- splitForAllTyCoVar_maybe s + , Just _ <- splitForAllTyCoVar_maybe t + , SelForAll <- cs + , (isForAllTy_ty s && isForAllTy_ty t) || (isForAllTy_co s && isForAllTy_co t) - -> do { lintRole the_co Nominal r0 - ; return (NthCo r0 n co') } - - ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of - { (Just (tc_s, tys_s), Just (tc_t, tys_t)) - | tc_s == tc_t - , isInjectiveTyCon tc_s r - -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep - , tys_s `equalLength` tys_t - , tys_s `lengthExceeds` n - -> do { lintRole the_co tr r0 - ; return (NthCo r0 n co') } - where - tr = nthRole r tc_s n - - ; _ -> failWithL (hang (text "Bad getNth:") - 2 (ppr the_co $$ ppr s $$ ppr t)) }}} + -> return (SelCo cs co') + + -- function + | isFunTy s + , isFunTy t + , SelFun {} <- cs + -> return (SelCo cs co') + + -- TyCon + | Just (tc_s, tys_s) <- splitTyConApp_maybe s + , Just (tc_t, tys_t) <- splitTyConApp_maybe t + , tc_s == tc_t + , SelTyCon n r0 <- cs + , isInjectiveTyCon tc_s co_role + -- see Note [SelCo and newtypes] in GHC.Core.TyCo.Rep + , tys_s `equalLength` tys_t + , tys_s `lengthExceeds` n + -> do { lintRole the_co (tyConRole co_role tc_s n) r0 + ; return (SelCo cs co') } + + | otherwise + -> failWithL (hang (text "Bad SelCo:") + 2 (ppr the_co $$ ppr s $$ ppr t)) } lintCoercion the_co@(LRCo lr co) = do { co' <- lintCoercion co @@ -2585,10 +2612,14 @@ lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs ; rhs' <- lintType rhs ; let lhs_kind = typeKind lhs' rhs_kind = typeKind rhs' - ; lintL (lhs_kind `eqType` rhs_kind) $ + ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $ hang (text "Inhomogeneous axiom") 2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$ text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) } + -- Type and Constraint are not Apart, so this test allows + -- the newtype axiom for a single-method class. Indeed the + -- whole reason Type and Constraint are not Apart is to allow + -- such axioms! -- these checks do not apply to newtype axioms lint_family_branch :: TyCon -> CoAxBranch -> LintM () @@ -3124,7 +3155,7 @@ varCallSiteUsage :: Id -> LintM UsageEnv varCallSiteUsage id = do m <- getUEAliases return $ case lookupNameEnv m (getName id) of - Nothing -> unitUE id One + Nothing -> unitUE id OneTy Just id_ue -> id_ue ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM () @@ -3135,7 +3166,7 @@ ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg ensureSubUsage :: Usage -> Mult -> SDoc -> LintM () ensureSubUsage Bottom _ _ = return () -ensureSubUsage Zero described_mult err_msg = ensureSubMult Many described_mult err_msg +ensureSubUsage Zero described_mult err_msg = ensureSubMult ManyTy described_mult err_msg ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg ensureSubMult :: Mult -> Mult -> SDoc -> LintM () diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 9c3b8edfee..c2fff4596c 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -1,5 +1,3 @@ - - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Handy functions for creating much Core syntax @@ -25,27 +23,22 @@ module GHC.Core.Make ( FloatBind(..), wrapFloat, wrapFloats, floatBindings, -- * Constructing small tuples - mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, mkCoreUbxSum, + mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUbxSum, mkCoreTupBoxity, unitExpr, -- * Constructing big tuples - mkBigCoreVarTup, mkBigCoreVarTup1, + mkChunkified, chunkify, + mkBigCoreVarTup, mkBigCoreVarTupSolo, mkBigCoreVarTupTy, mkBigCoreTupTy, mkBigCoreTup, - -- * Deconstructing small tuples - mkSmallTupleSelector, mkSmallTupleCase, - - -- * Deconstructing big tuples - mkTupleSelector, mkTupleSelector1, mkTupleCase, + -- * Deconstructing big tuples + mkBigTupleSelector, mkBigTupleSelectorSolo, mkBigTupleCase, -- * Constructing list expressions mkNilExpr, mkConsExpr, mkListExpr, mkFoldrExpr, mkBuildExpr, - -- * Constructing non empty lists - mkNonEmptyListExpr, - -- * Constructing Maybe expressions mkNothingExpr, mkJustExpr, @@ -53,7 +46,7 @@ module GHC.Core.Make ( mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, + pAT_ERROR_ID, rEC_SEL_ERROR_ID, tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID ) where @@ -61,7 +54,7 @@ import GHC.Prelude import GHC.Platform import GHC.Types.Id -import GHC.Types.Var ( EvVar, setTyVarUnique ) +import GHC.Types.Var ( EvVar, setTyVarUnique, visArgConstraintLike ) import GHC.Types.TyThing import GHC.Types.Id.Info import GHC.Types.Cpr @@ -73,12 +66,11 @@ import GHC.Types.Unique.Supply import GHC.Core import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec ) import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Coercion ( isCoVar ) import GHC.Core.DataCon ( DataCon, dataConWorkId ) import GHC.Core.Multiplicity -import GHC.Hs.Utils ( mkChunkified, chunkify ) - import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Builtin.Types.Prim @@ -88,6 +80,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Settings.Constants( mAX_TUPLE_SIZE ) import GHC.Data.FastString import Data.List ( partition ) @@ -171,9 +164,7 @@ mkCoreAppTyped _ (fun, fun_ty) (Coercion co) = (App fun (Coercion co), funResultTy fun_ty) mkCoreAppTyped d (fun, fun_ty) arg = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d) - (App fun arg, res_ty) - where - (_mult, _arg_ty, res_ty) = splitFunTy fun_ty + (App fun arg, funResultTy fun_ty) {- ********************************************************************* * * @@ -182,7 +173,7 @@ mkCoreAppTyped d (fun, fun_ty) arg ********************************************************************* -} mkWildEvBinder :: PredType -> EvVar -mkWildEvBinder pred = mkWildValBinder Many pred +mkWildEvBinder pred = mkWildValBinder ManyTy pred -- | Make a /wildcard binder/. This is typically used when you need a binder -- that you expect to use only at a *binding* site. Do not use it at @@ -221,7 +212,7 @@ castBottomExpr :: CoreExpr -> Type -> CoreExpr -- See Note [Empty case alternatives] in GHC.Core castBottomExpr e res_ty | e_ty `eqType` res_ty = e - | otherwise = Case e (mkWildValBinder One e_ty) res_ty [] + | otherwise = Case e (mkWildValBinder OneTy e_ty) res_ty [] where e_ty = exprType e @@ -238,9 +229,9 @@ mkLitRubbish ty | isCoVarType ty = Nothing -- Satisfy INVARIANT 2 | otherwise - = Just (Lit (LitRubbish rep) `mkTyApps` [ty]) + = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty]) where - rep = getRuntimeRep ty + Just (torc, rep) = sORTKind_maybe (typeKind ty) {- ************************************************************************ @@ -335,22 +326,12 @@ mkStringExprFSWith ids str {- ************************************************************************ * * -\subsection{Tuple constructors} + Creating tuples and their types for Core expressions * * ************************************************************************ -} -{- -Creating tuples and their types for Core expressions - -@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. - -* If it has only one element, it is the identity function. - -* If there are more elements than a big tuple can have, it nests - the tuples. - -Note [Flattening one-tuples] +{- Note [Flattening one-tuples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This family of functions creates a tuple of variables/expressions/types. mkCoreTup [e1,e2,e3] = (e1,e2,e3) @@ -361,8 +342,8 @@ We could do one of two things: mkCoreTup [e1] = e1 * Build a one-tuple (see Note [One-tuples] in GHC.Builtin.Types) - mkCoreTup1 [e1] = Solo e1 - We use a suffix "1" to indicate this. + mkCoreTupSolo [e1] = Solo e1 + We use a suffix "Solo" to indicate this. Usually we want the former, but occasionally the latter. @@ -380,41 +361,46 @@ This arose from discussions in #16881. One-tuples that arise internally depend on the circumstance; often flattening is a good idea. Decisions are made on a case-by-case basis. +'mkCoreBoxedTuple` and `mkBigCoreVarTupSolo` build tuples without flattening. -} --- | Build the type of a small tuple that holds the specified variables --- One-tuples are flattened; see Note [Flattening one-tuples] -mkCoreVarTupTy :: [Id] -> Type -mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) - --- | Build a small tuple holding the specified expressions --- One-tuples are flattened; see Note [Flattening one-tuples] -mkCoreTup :: [CoreExpr] -> CoreExpr -mkCoreTup [c] = c -mkCoreTup cs = mkCoreTup1 cs -- non-1-tuples are uniform - -- | Build a small tuple holding the specified expressions -- One-tuples are *not* flattened; see Note [Flattening one-tuples] -- See also Note [Don't flatten tuples from HsSyn] -mkCoreTup1 :: [CoreExpr] -> CoreExpr -mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs)) - (map (Type . exprType) cs ++ cs) +-- Arguments must have kind Type +mkCoreBoxedTuple :: HasDebugCallStack => [CoreExpr] -> CoreExpr +mkCoreBoxedTuple cs + = assertPpr (all (tcIsLiftedTypeKind . typeKind . exprType) cs) (ppr cs) + mkCoreConApps (tupleDataCon Boxed (length cs)) + (map (Type . exprType) cs ++ cs) + --- | Build a small unboxed tuple holding the specified expressions, --- with the given types. The types must be the types of the expressions. +-- | Build a small unboxed tuple holding the specified expressions. -- Do not include the RuntimeRep specifiers; this function calculates them -- for you. -- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] -mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr -mkCoreUbxTup tys exps - = assert (tys `equalLength` exps) $ - mkCoreConApps (tupleDataCon Unboxed (length tys)) - (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) +mkCoreUnboxedTuple :: [CoreExpr] -> CoreExpr +mkCoreUnboxedTuple exps + = mkCoreConApps (tupleDataCon Unboxed (length tys)) + (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) + where + tys = map exprType exps -- | Make a core tuple of the given boxity; don't flatten 1-tuples mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr -mkCoreTupBoxity Boxed exps = mkCoreTup1 exps -mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps +mkCoreTupBoxity Boxed exps = mkCoreBoxedTuple exps +mkCoreTupBoxity Unboxed exps = mkCoreUnboxedTuple exps + +-- | Build the type of a small tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreVarTupTy :: [Id] -> Type +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) + +-- | Build a small tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreTup :: [CoreExpr] -> CoreExpr +mkCoreTup [c] = c +mkCoreTup cs = mkCoreBoxedTuple cs -- non-1-tuples are uniform -- | Build an unboxed sum. -- @@ -428,37 +414,153 @@ mkCoreUbxSum arity alt tys exp ++ map Type tys ++ [exp]) +{- Note [Big tuples] +~~~~~~~~~~~~~~~~~~~~ +"Big" tuples (`mkBigCoreTup` and friends) are more general than "small" +ones (`mkCoreTup` and friends) in two ways. + +1. GHCs built-in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but + we might conceivably want to build such a massive tuple as part of the + output of a desugaring stage (notably that for list comprehensions). + + `mkBigCoreTup` encodes such big tuples by creating and pattern + matching on /nested/ small tuples that are directly expressible by + GHC. + + Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) + than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any + construction to be big. + +2. When desugaring arrows we gather up a tuple of free variables, which + may include dictionaries (of kind Constraint) and unboxed values. + + These can't live in a tuple. `mkBigCoreTup` encodes such tuples by + boxing up the offending arguments: see Note [Boxing constructors] + in GHC.Builtin.Types. + +If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkBigTupleSelector' +and 'mkBigTupleCase' functions to do all your work with tuples you should be +fine, and not have to worry about the arity limitation, or kind limitation at +all. + +The "big" tuple operations flatten 1-tuples just like "small" tuples. +But see Note [Don't flatten tuples from HsSyn] +-} + +mkBigCoreVarTupSolo :: [Id] -> CoreExpr +-- Same as mkBigCoreVarTup, but: +-- - one-tuples are not flattened +-- see Note [Flattening one-tuples] +-- - arguments should have kind Type +mkBigCoreVarTupSolo [id] = mkCoreBoxedTuple [Var id] +mkBigCoreVarTupSolo ids = mkChunkified mkCoreTup (map Var ids) + -- | Build a big tuple holding the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples] +-- Arguments don't have to have kind Type mkBigCoreVarTup :: [Id] -> CoreExpr mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) -mkBigCoreVarTup1 :: [Id] -> CoreExpr --- Same as mkBigCoreVarTup, but one-tuples are NOT flattened --- see Note [Flattening one-tuples] -mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1) - [Type (idType id), Var id] -mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids) +-- | Build a "big" tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +-- Arguments don't have to have kind Type; ones that do not are boxed +-- This function crashes (in wrapBox) if given a non-Type +-- argument that it doesn't know how to box. +mkBigCoreTup :: [CoreExpr] -> CoreExpr +mkBigCoreTup exprs = mkChunkified mkCoreTup (map wrapBox exprs) -- | Build the type of a big tuple that holds the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples] mkBigCoreVarTupTy :: [Id] -> Type mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) --- | Build a big tuple holding the specified expressions --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreTup :: [CoreExpr] -> CoreExpr -mkBigCoreTup = mkChunkified mkCoreTup - -- | Build the type of a big tuple that holds the specified type of thing -- One-tuples are flattened; see Note [Flattening one-tuples] mkBigCoreTupTy :: [Type] -> Type -mkBigCoreTupTy = mkChunkified mkBoxedTupleTy +mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $ + map boxTy tys -- | The unit expression unitExpr :: CoreExpr unitExpr = Var unitDataConId +-------------------------------------------------------------- +wrapBox :: CoreExpr -> CoreExpr +-- ^ If (e :: ty) and (ty :: Type), wrapBox is a no-op +-- But if (ty :: ki), and ki is not Type, wrapBox returns (K @ty e) +-- which has kind Type +-- where K is the boxing data constructor for ki +-- See Note [Boxing constructors] in GHC.Builtin.Types +-- Panics if there /is/ no boxing data con +wrapBox e + = case boxingDataCon e_ty of + BI_NoBoxNeeded -> e + BI_Box { bi_inst_con = boxing_expr } -> App boxing_expr e + BI_NoBoxAvailable -> pprPanic "wrapBox" (ppr e $$ ppr (exprType e)) + -- We should do better than panicing: #22336 + where + e_ty = exprType e + +boxTy :: Type -> Type +-- ^ `boxTy ty` is the boxed version of `ty`. That is, +-- if `e :: ty`, then `wrapBox e :: boxTy ty`. +-- Note that if `ty :: Type`, `boxTy ty` just returns `ty`. +-- Panics if it is not possible to box `ty`, like `wrapBox` (#22336) +-- See Note [Boxing constructors] in GHC.Builtin.Types +boxTy ty + = case boxingDataCon ty of + BI_NoBoxNeeded -> ty + BI_Box { bi_boxed_type = box_ty } -> box_ty + BI_NoBoxAvailable -> pprPanic "boxTy" (ppr ty) + -- We should do better than panicing: #22336 + +unwrapBox :: UniqSupply -> Id -> CoreExpr + -> (UniqSupply, Id, CoreExpr) +-- If v's type required boxing (i.e it is unlifted or a constraint) +-- then (unwrapBox us v body) returns +-- (case box_v of MkDict v -> body) +-- together with box_v +-- where box_v is a fresh variable +-- Otherwise unwrapBox is a no-op +-- Panics if no box is available (#22336) +unwrapBox us var body + = case boxingDataCon var_ty of + BI_NoBoxNeeded -> (us, var, body) + BI_NoBoxAvailable -> pprPanic "unwrapBox" (ppr var $$ ppr var_ty) + -- We should do better than panicing: #22336 + BI_Box { bi_data_con = box_con, bi_boxed_type = box_ty } + -> (us', var', body') + where + var' = mkSysLocal (fsLit "uc") uniq ManyTy box_ty + body' = Case (Var var') var' (exprType body) + [Alt (DataAlt box_con) [var] body] + where + var_ty = idType var + (uniq, us') = takeUniqFromSupply us + +-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition +mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' + -> [a] -- ^ Possible \"big\" list of things to construct from + -> a -- ^ Constructed thing made possible by recursive decomposition +mkChunkified small_tuple as = mk_big_tuple (chunkify as) + where + -- Each sub-list is short enough to fit in a tuple + mk_big_tuple [as] = small_tuple as + mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) + +chunkify :: [a] -> [[a]] +-- ^ Split a list into lists that are small enough to have a corresponding +-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' +-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists +chunkify xs + | n_xs <= mAX_TUPLE_SIZE = [xs] + | otherwise = split xs + where + n_xs = length xs + split [] = [] + split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) + + {- ************************************************************************ * * @@ -479,16 +581,16 @@ unitExpr = Var unitDataConId -- If necessary, we pattern match on a \"big\" tuple. -- -- A tuple selector is not linear in its argument. Consequently, the case --- expression built by `mkTupleSelector` must consume its scrutinee 'Many' +-- expression built by `mkBigTupleSelector` must consume its scrutinee 'Many' -- times. And all the argument variables must have multiplicity 'Many'. -mkTupleSelector, mkTupleSelector1 +mkBigTupleSelector, mkBigTupleSelectorSolo :: [Id] -- ^ The 'Id's to pattern match the tuple against -> Id -- ^ The 'Id' to select -> Id -- ^ A variable of the same type as the scrutinee -> CoreExpr -- ^ Scrutinee -> CoreExpr -- ^ Selector expression --- mkTupleSelector [a,b,c,d] b v e +-- mkBigTupleSelector [a,b,c,d] b v e -- = case e of v { -- (p,q) -> case p of p { -- (a,b) -> b }} @@ -499,7 +601,7 @@ mkTupleSelector, mkTupleSelector1 -- case (case e of v -- (p,q) -> p) of p -- (a,b) -> b -mkTupleSelector vars the_var scrut_var scrut +mkBigTupleSelector vars the_var scrut_var scrut = mk_tup_sel (chunkify vars) the_var where mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut @@ -508,18 +610,18 @@ mkTupleSelector vars the_var scrut_var scrut where tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] tpl_vs = mkTemplateLocals tpl_tys - [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, + [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkBigTupleSelector" tpl_vs vars_s, the_var `elem` gp ] --- ^ 'mkTupleSelector1' is like 'mkTupleSelector' +-- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector' -- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) -mkTupleSelector1 vars the_var scrut_var scrut +mkBigTupleSelectorSolo vars the_var scrut_var scrut | [_] <- vars = mkSmallTupleSelector1 vars the_var scrut_var scrut | otherwise - = mkTupleSelector vars the_var scrut_var scrut + = mkBigTupleSelector vars the_var scrut_var scrut --- | Like 'mkTupleSelector' but for tuples that are guaranteed --- never to be \"big\". +-- | `mkSmallTupleSelector` is like 'mkBigTupleSelector', but for tuples that +-- are guaranteed never to be "big". Also does not unwrap boxed types. -- -- > mkSmallTupleSelector [x] x v e = [| e |] -- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] @@ -542,45 +644,71 @@ mkSmallTupleSelector1 vars the_var scrut_var scrut Case scrut scrut_var (idType the_var) [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)] --- | A generalization of 'mkTupleSelector', allowing the body +-- | A generalization of 'mkBigTupleSelector', allowing the body -- of the case to be an arbitrary expression. -- -- To avoid shadowing, we use uniques to invent new variables. -- --- If necessary we pattern match on a \"big\" tuple. -mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables - -> [Id] -- ^ The tuple identifiers to pattern match on - -> CoreExpr -- ^ Body of the case - -> Id -- ^ A variable of the same type as the scrutinee - -> CoreExpr -- ^ Scrutinee - -> CoreExpr +-- If necessary we pattern match on a "big" tuple. +mkBigTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables + -> [Id] -- ^ The tuple identifiers to pattern match on; + -- Bring these into scope in the body + -> CoreExpr -- ^ Body of the case + -> CoreExpr -- ^ Scrutinee + -> CoreExpr -- ToDo: eliminate cases where none of the variables are needed. -- --- mkTupleCase uniqs [a,b,c,d] body v e +-- mkBigTupleCase uniqs [a,b,c,d] body v e -- = case e of v { (p,q) -> -- case p of p { (a,b) -> -- case q of q { (c,d) -> -- body }}} -mkTupleCase uniqs vars body scrut_var scrut - = mk_tuple_case uniqs (chunkify vars) body +mkBigTupleCase us vars body scrut + = mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body where + (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars + + scrut_ty = exprType scrut + + unwrap var (us,vars,body) + = (us', var':vars, body') + where + (us', var', body') = unwrapBox us var body + + mk_tuple_case :: UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr + -- mk_tuple_case [[a1..an], [b1..bm], ...] body + -- case scrut of (p,q, ...) -> + -- case p of (a1,..an) -> + -- case q of (b1,..bm) -> + -- ... -> body -- This is the case where don't need any nesting - mk_tuple_case _ [vars] body + mk_tuple_case us [vars] body = mkSmallTupleCase vars body scrut_var scrut + where + scrut_var = case scrut of + Var v -> v + _ -> snd (new_var us scrut_ty) - -- This is the case where we must make nest tuples at least once + -- This is the case where we must nest tuples at least once mk_tuple_case us vars_s body - = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s - in mk_tuple_case us' (chunkify vars') body' + = mk_tuple_case us' (chunkify vars') body' + where + (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s one_tuple_case chunk_vars (us, vs, body) - = let (uniq, us') = takeUniqFromSupply us - scrut_var = mkSysLocal (fsLit "ds") uniq Many - (mkBoxedTupleTy (map idType chunk_vars)) - body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) - in (us', scrut_var:vs, body') - --- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed + = (us', scrut_var:vs, body') + where + tup_ty = mkBoxedTupleTy (map idType chunk_vars) + (us', scrut_var) = new_var us tup_ty + body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) + + new_var :: UniqSupply -> Type -> (UniqSupply, Id) + new_var us ty = (us', id) + where + (uniq, us') = takeUniqFromSupply us + id = mkSysLocal (fsLit "ds") uniq ManyTy ty + +-- | As 'mkBigTupleCase', but for a tuple that is small enough to be guaranteed -- not to need nesting. mkSmallTupleCase :: [Id] -- ^ The tuple args @@ -592,7 +720,6 @@ mkSmallTupleCase mkSmallTupleCase [var] body _scrut_var scrut = bindNonRec var scrut body mkSmallTupleCase vars body scrut_var scrut --- One branch no refinement? = Case scrut scrut_var (exprType body) [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body] @@ -655,9 +782,6 @@ mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] mkListExpr :: Type -> [CoreExpr] -> CoreExpr mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs -mkNonEmptyListExpr :: Type -> CoreExpr -> [CoreExpr] -> CoreExpr -mkNonEmptyListExpr ty x xs = mkCoreConApps nonEmptyDataCon [Type ty, x, mkListExpr ty xs] - -- | Make a fully applied 'foldr' expression mkFoldrExpr :: MonadThings m => Type -- ^ Element type of the list @@ -685,7 +809,7 @@ mkBuildExpr elt_ty mk_build_inside = do n_tyvar <- newTyVar alphaTyVar let n_ty = mkTyVarTy n_tyvar c_ty = mkVisFunTysMany [elt_ty, n_ty] n_ty - [c, n] <- sequence [mkSysLocalM (fsLit "c") Many c_ty, mkSysLocalM (fsLit "n") Many n_ty] + [c, n] <- sequence [mkSysLocalM (fsLit "c") ManyTy c_ty, mkSysLocalM (fsLit "n") ManyTy n_ty] build_inside <- mk_build_inside (c, c_ty) (n, n_ty) @@ -766,12 +890,12 @@ errorIds pAT_ERROR_ID, rEC_CON_ERROR_ID, rEC_SEL_ERROR_ID, - aBSENT_ERROR_ID, + aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID, tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 ] -recSelErrorName, runtimeErrorName, absentErrorName :: Name +recSelErrorName, runtimeErrorName :: Name recConErrorName, patErrorName :: Name nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name typeErrorName :: Name @@ -793,7 +917,7 @@ err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id -tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id +tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName @@ -901,13 +1025,6 @@ absentSumFieldErrorName absentSumFieldErrorIdKey aBSENT_SUM_FIELD_ERROR_ID -absentErrorName - = mkWiredInIdName - gHC_PRIM_PANIC - (fsLit "absentError") - absentErrorIdKey - aBSENT_ERROR_ID - aBSENT_SUM_FIELD_ERROR_ID = mkExceptionId absentSumFieldErrorName -- | Exception with type \"forall a. a\" @@ -1054,19 +1171,51 @@ but that should be okay; since there's no pattern match we can't really be relying on anything from it. -} -aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID] - = mkVanillaGlobalWithInfo absentErrorName absent_ty id_info - where - absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany addrPrimTy alphaTy) - -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for - -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils - id_info = divergingIdInfo [evalDmd] -- NB: CAFFY! +-- We need two absentError Ids: +-- absentError :: forall (a :: Type). Addr# -> a +-- absentConstraintError :: forall (a :: Constraint). Addr# -> a +-- We don't have polymorphism over TypeOrConstraint! +-- mkAbsentErrorApp chooses which one to use, based on the kind mkAbsentErrorApp :: Type -- The type to instantiate 'a' -> String -- The string to print -> CoreExpr mkAbsentErrorApp res_ty err_msg - = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] + = mkApps (Var err_id) [ Type res_ty, err_string ] where + err_id | isConstraintLikeKind (typeKind res_ty) = aBSENT_CONSTRAINT_ERROR_ID + | otherwise = aBSENT_ERROR_ID err_string = Lit (mkLitString err_msg) + +absentErrorName, absentConstraintErrorName :: Name +absentErrorName + = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentError") + absentErrorIdKey aBSENT_ERROR_ID + +absentConstraintErrorName + = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentConstraintError") + absentConstraintErrorIdKey aBSENT_CONSTRAINT_ERROR_ID + +aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id + +aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID] + = mkVanillaGlobalWithInfo absentErrorName absent_ty id_info + where + -- absentError :: forall (a :: Type). Addr# -> a + absent_ty = mkSpecForAllTys [alphaTyVar] $ + mkVisFunTyMany addrPrimTy (mkTyVarTy alphaTyVar) + -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for + -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils + id_info = divergingIdInfo [evalDmd] -- NB: CAFFY! + +aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID] + = mkVanillaGlobalWithInfo absentConstraintErrorName absent_ty id_info + where + -- absentConstraintError :: forall (a :: Constraint). Addr# -> a + absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $ + mkFunTy visArgConstraintLike ManyTy + addrPrimTy (mkTyVarTy alphaConstraintTyVar) + id_info = divergingIdInfo [evalDmd] -- NB: CAFFY! + + diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs index 61fca8353a..96eefd65e9 100644 --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -150,9 +150,8 @@ instance Eq (DeBruijn CoreExpr) where eqDeBruijnExpr :: DeBruijn CoreExpr -> DeBruijn CoreExpr -> Bool eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where - go (Var v1) (Var v2) = eqDeBruijnVar (D env1 v1) (D env2 v2) + go (Var v1) (Var v2) = eqDeBruijnVar (D env1 v1) (D env2 v2) go (Lit lit1) (Lit lit2) = lit1 == lit2 - -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type go (Type t1) (Type t2) = eqDeBruijnType (D env1 t1) (D env2 t2) -- See Note [Alpha-equality for Coercion arguments] go (Coercion {}) (Coercion {}) = True @@ -163,7 +162,6 @@ eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where && go e1 e2 go (Lam b1 e1) (Lam b2 e2) - -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type = eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2)) && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2) && eqDeBruijnExpr (D (extendCME env1 b1) e1) (D (extendCME env2 b2) e2) @@ -175,9 +173,7 @@ eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where go (Let (Rec ps1) e1) (Let (Rec ps2) e2) = equalLength ps1 ps2 -- See Note [Alpha-equality for let-bindings] - && all2 (\b1 b2 -> -- See Note [Using tcView inside eqDeBruijnType] in - -- GHC.Core.Map.Type - eqDeBruijnType (D env1 (varType b1)) + && all2 (\b1 b2 -> eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2))) bs1 bs2 && D env1' rs1 == D env2' rs2 diff --git a/compiler/GHC/Core/Map/Type.hs b/compiler/GHC/Core/Map/Type.hs index 45468e654f..e57222075a 100644 --- a/compiler/GHC/Core/Map/Type.hs +++ b/compiler/GHC/Core/Map/Type.hs @@ -38,6 +38,7 @@ import GHC.Prelude import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( eqForAllVis ) import GHC.Data.TrieMap import GHC.Data.FastString @@ -54,7 +55,6 @@ import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Control.Monad ( (>=>) ) -import GHC.Data.Maybe -- NB: Be careful about RULES and type families (#5821). So we should make sure -- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) @@ -149,13 +149,6 @@ data TypeMapX a = TM { tm_var :: VarMap a , tm_app :: TypeMapG (TypeMapG a) -- Note [Equality on AppTys] in GHC.Core.Type , tm_tycon :: DNameEnv a - - -- only InvisArg arrows here - , tm_funty :: TypeMapG (TypeMapG (TypeMapG a)) - -- keyed on the argument, result rep, and result - -- constraints are never linear-restricted and are always lifted - -- See also Note [Equality on FunTys] in GHC.Core.TyCo.Rep - , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr , tm_tylit :: TyLitMap a , tm_coerce :: Maybe a @@ -165,28 +158,27 @@ data TypeMapX a -- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the -- last one? See Note [Equality on AppTys] in GHC.Core.Type -- --- Note, however, that we keep Constraint and Type apart here, despite the fact --- that they are both synonyms of TYPE 'LiftedRep (see #11715). --- -- We also keep (Eq a => a) as a FunTy, distinct from ((->) (Eq a) a). trieMapView :: Type -> Maybe Type trieMapView ty -- First check for TyConApps that need to be expanded to - -- AppTy chains. - | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty + -- AppTy chains. This includes eliminating FunTy entirely. + | Just (tc, tys@(_:_)) <- splitTyConApp_maybe ty = Just $ foldl' AppTy (mkTyConTy tc) tys -- Then resolve any remaining nullary synonyms. - | Just ty' <- tcView ty = Just ty' + | Just ty' <- coreView ty + = Just ty' + trieMapView _ = Nothing -- TODO(22292): derive instance Functor TypeMapX where fmap f TM - { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon, tm_funty = tfunty, tm_forall = tforall + { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon, tm_forall = tforall , tm_tylit = tlit, tm_coerce = tcoerce } = TM { tm_var = fmap f tvar, tm_app = fmap (fmap f) tapp, tm_tycon = fmap f ttycon - , tm_funty = fmap (fmap (fmap f)) tfunty, tm_forall = fmap (fmap f) tforall + , tm_forall = fmap (fmap f) tforall , tm_tylit = fmap f tlit, tm_coerce = fmap f tcoerce } instance TrieMap TypeMapX where @@ -200,27 +192,6 @@ instance TrieMap TypeMapX where instance Eq (DeBruijn Type) where (==) = eqDeBruijnType -{- Note [Using tcView inside eqDeBruijnType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -`eqDeBruijnType` uses `tcView` and thus treats Type and Constraint as -distinct -- see Note [coreView vs tcView] in GHC.Core.Type. We do that because -`eqDeBruijnType` is used in TrieMaps, which are used for instance for instance -selection in the type checker. [Or at least will be soon.] - -However, the odds that we have two expressions that are identical save for the -'Type'/'Constraint' distinction are low. (Not impossible to do. But doubtful -anyone has ever done so in the history of Haskell.) - -And it's actually all OK: 'eqCoreExpr' is conservative: if `eqCoreExpr e1 e2` returns -'True', thne it must be that `e1` behaves identically to `e2` in all contexts. -But if `eqCoreExpr e1 e2` returns 'False', then we learn nothing. The use of -'tcView' where we expect 'coreView' means 'eqCoreExpr' returns 'False' bit more -often that it should. This might, say, stop a `RULE` from firing or CSE from -optimizing an expression. Stopping `RULE` firing is good actually: `RULES` are -written in Haskell, where `Type /= Constraint`. Stopping CSE is unfortunate, -but tolerable. --} - -- | An equality relation between two 'Type's (known below as @t1 :: k2@ -- and @t2 :: k2@) data TypeEquality = TNEQ -- ^ @t1 /= t2@ @@ -262,9 +233,8 @@ eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) = | tc1 == tc2 = TEQ go env_t@(D env t) env_t'@(D env' t') - -- See Note [Using tcView inside eqDeBruijnType] - | Just new_t <- tcView t = go (D env new_t) env_t' - | Just new_t' <- tcView t' = go env_t (D env' new_t') + | Just new_t <- coreView t = go (D env new_t) env_t' + | Just new_t' <- coreView t' = go env_t (D env' new_t') | otherwise = case (t, t') of -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep @@ -274,9 +244,9 @@ eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) = (TyVarTy v, TyVarTy v') -> liftEquality $ eqDeBruijnVar (D env v) (D env' v') -- See Note [Equality on AppTys] in GHC.Core.Type - (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s + (AppTy t1 t2, s) | Just (t1', t2') <- splitAppTyNoView_maybe s -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2') - (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s + (s, AppTy t1' t2') | Just (t1, t2) <- splitAppTyNoView_maybe s -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2') (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2') @@ -292,9 +262,9 @@ eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) = (LitTy l, LitTy l') -> liftEquality (l == l') (ForAllTy (Bndr tv vis) ty, ForAllTy (Bndr tv' vis') ty') - -> -- See Note [ForAllTy and typechecker equality] in - -- GHC.Tc.Solver.Canonical for why we use `sameVis` here - liftEquality (vis `sameVis` vis') `andEq` + -> -- See Note [ForAllTy and type equality] in + -- GHC.Core.TyCo.Compare for why we use `eqForAllVis` here + liftEquality (vis `eqForAllVis` vis') `andEq` go (D env (varType tv)) (D env' (varType tv')) `andEq` go (D (extendCME env tv) ty) (D (extendCME env' tv') ty') (CoercionTy {}, CoercionTy {}) @@ -324,7 +294,6 @@ emptyT :: TypeMapX a emptyT = TM { tm_var = emptyTM , tm_app = emptyTM , tm_tycon = emptyDNameEnv - , tm_funty = emptyTM , tm_forall = emptyTM , tm_tylit = emptyTyLitMap , tm_coerce = Nothing } @@ -338,19 +307,17 @@ lkT (D env ty) m = go ty m go (AppTy t1 t2) = tm_app >.> lkG (D env t1) >=> lkG (D env t2) go (TyConApp tc []) = tm_tycon >.> lkDNamed tc - go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) go (LitTy l) = tm_tylit >.> lkTyLit l go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) >=> lkBndr env tv - go (FunTy InvisArg _ arg res) - | Just res_rep <- getRuntimeRep_maybe res - = tm_funty >.> lkG (D env arg) - >=> lkG (D env res_rep) - >=> lkG (D env res) - go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) go (CastTy t _) = go t go (CoercionTy {}) = tm_coerce + -- trieMapView has eliminated non-nullary TyConApp + -- and FunTy into an AppTy chain + go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) + go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) + ----------------- xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m @@ -359,16 +326,15 @@ xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) |>> xtG (D env t2) f } xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } -xtT (D env (FunTy InvisArg _ t1 t2)) f m = m { tm_funty = tm_funty m |> xtG (D env t1) - |>> xtG (D env t2_rep) - |>> xtG (D env t2) f } - where t2_rep = expectJust "xtT FunTy InvisArg" (getRuntimeRep_maybe t2) xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } xtT (D env (CastTy t _)) f m = xtT (D env t) f m xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } xtT (D env (ForAllTy (Bndr tv _) ty)) f m = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) |>> xtBndr env tv f } + +-- trieMapView has eliminated non-nullary TyConApp +-- and FunTy into an AppTy chain xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) @@ -376,19 +342,17 @@ fdT :: (a -> b -> b) -> TypeMapX a -> b -> b fdT k m = foldTM k (tm_var m) . foldTM (foldTM k) (tm_app m) . foldTM k (tm_tycon m) - . foldTM (foldTM (foldTM k)) (tm_funty m) . foldTM (foldTM k) (tm_forall m) . foldTyLit k (tm_tylit m) . foldMaybe k (tm_coerce m) filterT :: (a -> Bool) -> TypeMapX a -> TypeMapX a filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon - , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit + , tm_forall = tforall, tm_tylit = tlit , tm_coerce = tcoerce }) = TM { tm_var = filterTM f tvar , tm_app = fmap (filterTM f) tapp , tm_tycon = filterTM f ttycon - , tm_funty = fmap (fmap (filterTM f)) tfunty , tm_forall = fmap (filterTM f) tforall , tm_tylit = filterTM f tlit , tm_coerce = filterMaybe f tcoerce } diff --git a/compiler/GHC/Core/Multiplicity.hs b/compiler/GHC/Core/Multiplicity.hs index 9d95cb4f9c..4132533b1b 100644 --- a/compiler/GHC/Core/Multiplicity.hs +++ b/compiler/GHC/Core/Multiplicity.hs @@ -11,8 +11,8 @@ mkMultMul perform simplifications such as Many * x = Many on the fly. -} module GHC.Core.Multiplicity ( Mult - , pattern One - , pattern Many + , pattern OneTy + , pattern ManyTy , isMultMul , mkMultAdd , mkMultMul @@ -29,14 +29,16 @@ module GHC.Core.Multiplicity , scaleScaled , IsSubmult(..) , submult - , mapScaledType) where + , mapScaledType + , pprArrowWithMultiplicity ) where import GHC.Prelude import GHC.Utils.Outputable +import GHC.Core.Type import GHC.Core.TyCo.Rep +import GHC.Types.Var( isFUNArg ) import {-# SOURCE #-} GHC.Builtin.Types ( multMulTyCon ) -import GHC.Core.Type import GHC.Builtin.Names (multMulTyConKey) import GHC.Types.Unique (hasKey) @@ -295,13 +297,13 @@ that the summands and factors are ordered somehow, to have more equalities. -- With only two multiplicities One and Many, we can always replace -- p + q by Many. See Note [Overapproximating multiplicities]. mkMultAdd :: Mult -> Mult -> Mult -mkMultAdd _ _ = Many +mkMultAdd _ _ = ManyTy mkMultMul :: Mult -> Mult -> Mult -mkMultMul One p = p -mkMultMul p One = p -mkMultMul Many _ = Many -mkMultMul _ Many = Many +mkMultMul OneTy p = p +mkMultMul p OneTy = p +mkMultMul ManyTy _ = ManyTy +mkMultMul _ ManyTy = ManyTy mkMultMul p q = mkTyConApp multMulTyCon [p, q] scaleScaled :: Mult -> Scaled a -> Scaled a @@ -329,8 +331,25 @@ instance Outputable IsSubmult where -- value of multiplicity @w2@ is expected. This is a partial order. submult :: Mult -> Mult -> IsSubmult -submult _ Many = Submult -submult One One = Submult +submult _ ManyTy = Submult +submult OneTy OneTy = Submult -- The 1 <= p rule -submult One _ = Submult +submult OneTy _ = Submult submult _ _ = Unknown + +pprArrowWithMultiplicity :: FunTyFlag -> Either Bool SDoc -> SDoc +-- Pretty-print a multiplicity arrow. The multiplicity itself +-- is described by the (Either Bool SDoc) +-- Left False -- Many +-- Left True -- One +-- Right doc -- Something else +-- In the Right case, the doc is in parens if not atomic +pprArrowWithMultiplicity af pp_mult + | isFUNArg af + = case pp_mult of + Left False -> arrow + Left True -> lollipop + Right doc -> text "%" <> doc <+> arrow + | otherwise + = ppr (funTyFlagTyCon af) + diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 51d14be05a..df2a5c31c9 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -64,6 +64,7 @@ import GHC.Core.Multiplicity import GHC.Core.Subst as Core import GHC.Core.Type as Type import GHC.Core.Coercion as Type +import GHC.Core.TyCo.Compare( eqType ) import GHC.Types.Demand import GHC.Types.Cpr( CprSig, mkCprSig, botCpr ) @@ -196,7 +197,7 @@ typeOneShots ty | Just (_, ty') <- splitForAllTyCoVar_maybe ty = go rec_nts ty' - | Just (_,arg,res) <- splitFunTy_maybe ty + | Just (_,_,arg,res) <- splitFunTy_maybe ty = typeOneShot arg : go rec_nts res | Just (tc,tys) <- splitTyConApp_maybe ty @@ -2236,7 +2237,7 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty = (in_scope, EI (tcv' : bs) (mkHomoForAllMCo tcv' mco)) ----------- Function types (t1 -> t2) - | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty + | Just (_af, mult, arg_ty, res_ty) <- splitFunTy_maybe ty , typeHasFixedRuntimeRep arg_ty -- See Note [Representation polymorphism invariants] in GHC.Core -- See also test case typecheck/should_run/EtaExpandLevPoly @@ -2246,7 +2247,7 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty , let eta_id' = eta_id `setIdOneShotInfo` one_shot , (in_scope, EI bs mco) <- go (n+1) oss1 subst' res_ty - = (in_scope, EI (eta_id' : bs) (mkFunResMCo (idScaledType eta_id') mco)) + = (in_scope, EI (eta_id' : bs) (mkFunResMCo eta_id' mco)) ----------- Newtypes -- Given this: @@ -2709,15 +2710,15 @@ tryEtaReduce rec_ids bndrs body eval_sd ok_arg bndr (Var v) co fun_ty | bndr == v , let mult = idMult bndr - , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty + , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort - = Just (mkFunResCo Representational (idScaledType bndr) co, []) + = Just (mkFunResCo Representational bndr co, []) ok_arg bndr (Cast e co_arg) co fun_ty | (ticks, Var v) <- stripTicksTop tickishFloatable e - , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty + , Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty , bndr == v , fun_mult `eqType` idMult bndr - = Just (mkFunCo Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) + = Just (mkFunCoNoFTF Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here ok_arg bndr (Tick t arg) co fun_ty @@ -2824,19 +2825,19 @@ pushCoTyArg co ty = Nothing where Pair tyL tyR = coercionKind co - -- co :: tyL ~ tyR + -- co :: tyL ~R tyR -- tyL = forall (a1 :: k1). ty1 -- tyR = forall (a2 :: k2). ty2 - co1 = mkSymCo (mkNthCo Nominal 0 co) + co1 = mkSymCo (mkSelCo SelForAll co) -- co1 :: k2 ~N k1 - -- Note that NthCo can extract a Nominal equality between the + -- Note that SelCo extracts a Nominal equality between the -- kinds of the types related by a coercion between forall-types. - -- See the NthCo case in GHC.Core.Lint. + -- See the SelCo case in GHC.Core.Lint. co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) - -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] - -- Arg of mkInstCo is always nominal, hence mkNomReflCo + -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ] + -- Arg of mkInstCo is always nominal, hence Nominal -- | If @pushCoValArg co = Just (co_arg, co_res)@, then -- @@ -2860,7 +2861,7 @@ pushCoValArg co = Just (MRefl, MRefl) | isFunTy tyL - , (co_mult, co1, co2) <- decomposeFunCo Representational co + , (co_mult, co1, co2) <- decomposeFunCo co -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) -- then co1 :: tyL1 ~ tyR1 -- co2 :: tyL2 ~ tyR2 @@ -2902,9 +2903,9 @@ pushCoercionIntoLambda pushCoercionIntoLambda in_scope x e co | assert (not (isTyVar x) && not (isCoVar x)) True , Pair s1s2 t1t2 <- coercionKind co - , Just (_, _s1,_s2) <- splitFunTy_maybe s1s2 - , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2 - , (co_mult, co1, co2) <- decomposeFunCo Representational co + , Just {} <- splitFunTy_maybe s1s2 + , Just (_, w1, t1,_t2) <- splitFunTy_maybe t1t2 + , (co_mult, co1, co2) <- decomposeFunCo co , isReflexiveCo co_mult -- We can't push the coercion in the case where co_mult isn't -- reflexivity. See pushCoValArg for more details. @@ -2992,11 +2993,11 @@ pushCoDataCon dc dc_args co collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) -- Collect lambda binders, pushing coercions inside if possible -- E.g. (\x.e) |> g g :: <Int> -> blah --- = (\x. e |> Nth 1 g) +-- = (\x. e |> SelCo (SelFun SelRes) g) -- -- That is, -- --- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) +-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> SelCo (SelFun SelRes) g) collectBindersPushingCo e = go [] e where @@ -3023,21 +3024,21 @@ collectBindersPushingCo e , let Pair tyL tyR = coercionKind co , assert (isForAllTy_ty tyL) $ isForAllTy_ty tyR - , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] + , isReflCo (mkSelCo SelForAll co) -- See Note [collectBindersPushingCo] = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) | isCoVar b , let Pair tyL tyR = coercionKind co , assert (isForAllTy_co tyL) $ isForAllTy_co tyR - , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] + , isReflCo (mkSelCo SelForAll co) -- See Note [collectBindersPushingCo] , let cov = mkCoVarCo b = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) | isId b , let Pair tyL tyR = coercionKind co , assert (isFunTy tyL) $ isFunTy tyR - , (co_mult, co_arg, co_res) <- decomposeFunCo Representational co + , (co_mult, co_arg, co_res) <- decomposeFunCo co , isReflCo co_mult -- See Note [collectBindersPushingCo] , isReflCo co_arg -- See Note [collectBindersPushingCo] = go_c (b:bs) e co_res @@ -3103,7 +3104,7 @@ etaBodyForJoinPoint need_args body | Just (tv, res_ty) <- splitForAllTyCoVar_maybe ty , let (subst', tv') = substVarBndr subst tv = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') - | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty + | Just (_, mult, arg_ty, res_ty) <- splitFunTy_maybe ty , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty) = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b) | otherwise diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index 265c4fb57e..7a1c0c4305 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -728,7 +728,7 @@ resDel :: Var -> CallArityRes -> CallArityRes resDel v (!g, !ae) = (g `delNode` v, ae `delVarEnv` v) domRes :: CallArityRes -> UnVarSet -domRes (_, ae) = varEnvDom ae +domRes (_, ae) = varEnvDomain ae -- In the result, find out the minimum arity and whether the variable is called -- at most once. diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 9b81479970..1d59d33d65 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -46,11 +46,12 @@ import GHC.Core import GHC.Core.Make import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe ) import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) -import GHC.Core.Utils ( cheapEqExpr, exprIsHNF, exprType +import GHC.Core.Utils ( cheapEqExpr, exprIsHNF , stripTicksTop, stripTicksTopT, mkTicks ) import GHC.Core.Multiplicity import GHC.Core.Rules.Config import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon , isNewTyCon, tyConDataCons @@ -419,15 +420,14 @@ primOpRules nm = \case [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- getArgs platform <- getPlatform let r = l1 * l2 - pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy] + pure $ mkCoreUnboxedTuple [ Lit (if platformInIntRange platform r then zeroi platform else onei platform) , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform) , mkIntLitWrap platform r ] , zeroElem >>= \z -> - pure (mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy] - [z,z,z]) + pure (mkCoreUnboxedTuple [z,z,z]) -- timesInt2# 1# other -- ~~~> @@ -436,7 +436,7 @@ primOpRules nm = \case -- repeated to fill a word. , identityPlatform onei >>= \other -> do platform <- getPlatform - pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy] + pure $ mkCoreUnboxedTuple [ Lit (zeroi platform) , mkCoreApps (Var (primOpId IntSubOp)) [ Lit (zeroi platform) @@ -999,8 +999,7 @@ retLit l = do platform <- getPlatform retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr retLitNoC l = do platform <- getPlatform let lit = l platform - let ty = literalType lit - return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)] + return $ mkCoreUnboxedTuple [Lit lit, Lit (zeroi platform)] word8Op2 :: (Integral a, Integral b) @@ -1095,9 +1094,8 @@ floatOp2 _ _ _ _ = Nothing -------------------------- floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e))) - = Just $ mkCoreUbxTup [intPrimTy, intPrimTy] - [ mkIntVal (roPlatform env) (toInteger m) - , mkIntVal (roPlatform env) (toInteger e) ] + = Just $ mkCoreUnboxedTuple [ mkIntVal (roPlatform env) (toInteger m) + , mkIntVal (roPlatform env) (toInteger e) ] floatDecodeOp _ _ = Nothing @@ -1112,16 +1110,14 @@ doubleOp2 _ _ _ _ = Nothing -------------------------- doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e))) - = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy] - [ Lit (mkLitINT64 (toInteger m)) - , mkIntVal platform (toInteger e) ] + = Just $ mkCoreUnboxedTuple [ Lit (mkLitINT64 (toInteger m)) + , mkIntVal platform (toInteger e) ] where platform = roPlatform env - (iNT64Ty, mkLitINT64) - | platformWordSizeInBits platform < 64 - = (int64PrimTy, mkLitInt64Wrap) - | otherwise - = (intPrimTy , mkLitIntWrap platform) + mkLitINT64 | platformWordSizeInBits platform < 64 + = mkLitInt64Wrap + | otherwise + = mkLitIntWrap platform doubleDecodeOp _ _ = Nothing @@ -1226,9 +1222,8 @@ intResult' platform result = Lit (mkLitIntWrap platform result) -- Integer is in the target Int range and the corresponding overflow flag -- (@0#@/@1#@) if it wasn't. intCResult :: Platform -> Integer -> Maybe CoreExpr -intCResult platform result = Just (mkPair [Lit lit, Lit c]) +intCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c]) where - mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] (lit, b) = mkLitIntWrapC platform result c = if b then onei platform else zeroi platform @@ -1268,9 +1263,8 @@ wordResult' platform result = Lit (mkLitWordWrap platform result) -- Integer is in the target Word range and the corresponding carry flag -- (@0#@/@1#@) if it wasn't. wordCResult :: Platform -> Integer -> Maybe CoreExpr -wordCResult platform result = Just (mkPair [Lit lit, Lit c]) +wordCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c]) where - mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] (lit, b) = mkLitWordWrapC platform result c = if b then onei platform else zeroi platform @@ -1624,7 +1618,7 @@ leftIdentityCPlatform id_lit = do [Lit l1, e2] <- getArgs guard $ l1 == id_lit platform let no_c = Lit (zeroi platform) - return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c]) + return (mkCoreUnboxedTuple [e2, no_c]) rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr rightIdentityPlatform id_lit = do @@ -1641,7 +1635,7 @@ rightIdentityCPlatform id_lit = do [e1, Lit l2] <- getArgs guard $ l2 == id_lit platform let no_c = Lit (zeroi platform) - return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c]) + return (mkCoreUnboxedTuple [e1, no_c]) identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr identityPlatform lit = @@ -1956,9 +1950,9 @@ Implementing seq#. The compiler has magic for SeqOp in seqRule :: RuleM CoreExpr seqRule = do - [Type ty_a, Type _ty_s, a, s] <- getArgs + [Type _ty_a, Type _ty_s, a, s] <- getArgs guard $ exprIsHNF a - return $ mkCoreUbxTup [exprType s, ty_a] [s, a] + return $ mkCoreUnboxedTuple [s, a] -- spark# :: forall a s . a -> State# s -> (# State# s, a #) sparkRule :: RuleM CoreExpr @@ -2136,12 +2130,12 @@ builtinBignumRules = , divop_one "integerRem" integerRemName rem mkIntegerExpr , divop_one "integerDiv" integerDivName div mkIntegerExpr , divop_one "integerMod" integerModName mod mkIntegerExpr - , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr integerTy - , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr integerTy + , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr + , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr , divop_one "naturalQuot" naturalQuotName quot mkNaturalExpr , divop_one "naturalRem" naturalRemName rem mkNaturalExpr - , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr naturalTy + , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr -- conversions from Rational for Float/Double literals , rational_to "rationalToFloat" rationalToFloatName mkFloatExpr @@ -2291,14 +2285,14 @@ builtinBignumRules = platform <- getPlatform pure $ mk_lit platform (n `divop` d) - divop_both str name divop mk_lit ty = mkRule str name 2 $ do + divop_both str name divop mk_lit = mkRule str name 2 $ do [a0,a1] <- getArgs n <- isBignumLiteral a0 d <- isBignumLiteral a1 guard (d /= 0) let (r,s) = n `divop` d platform <- getPlatform - pure $ mkCoreUbxTup [ty,ty] [mk_lit platform r, mk_lit platform s] + pure $ mkCoreUnboxedTuple [mk_lit platform r, mk_lit platform s] integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule integer_encode_float str name mk_lit = mkRule str name 2 $ do diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index a428aeb8f0..a14964c12e 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -34,7 +34,8 @@ import GHC.Core.Type import GHC.Core.Predicate( isClassPred ) import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion ) -import GHC.Core.TyCo.FVs ( coVarsOfCos ) +import GHC.Core.TyCo.FVs ( coVarsOfCos ) +import GHC.Core.TyCo.Compare ( eqType ) import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc @@ -1112,7 +1113,7 @@ thresholdArity fn rhs resultType_maybe :: Id -> Maybe Type resultType_maybe id | (pis,ret_ty) <- splitPiTys (idType id) - , count (not . isNamedBinder) pis == idArity id + , count isAnonPiTyBinder pis == idArity id = Just $! ret_ty | otherwise = Nothing diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs index 7946f9f17b..6ad4614286 100644 --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -265,7 +265,7 @@ mkExitJoinId in_scope ty join_arity = do `extendInScopeSet` exit_id_tmpl -- just cosmetics return (uniqAway avoid exit_id_tmpl) where - exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique Many ty + exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty `asJoinId` join_arity addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index b970270cfe..2fdd5ba362 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -77,12 +77,11 @@ import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr ) import GHC.Core.FVs -- all of it import GHC.Core.Subst import GHC.Core.Make ( sortQuantVars ) -import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType +import GHC.Core.Type ( Type, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet , typeHasFixedRuntimeRep ) -import GHC.Core.Multiplicity ( pattern Many ) -import GHC.Core.DataCon ( dataConOrigResTy ) +import GHC.Core.Multiplicity ( pattern ManyTy ) import GHC.Types.Id import GHC.Types.Id.Info @@ -464,7 +463,7 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] , not (isTopLvl dest_lvl) -- Can't have top-level cases , not (floatTopLvlOnly env) -- Can float anywhere - , Many <- idMult case_bndr -- See Note [Floating linear case] + , ManyTy <- idMult case_bndr -- See Note [Floating linear case] = -- Always float the case if possible -- Unlike lets we don't insist that it escapes a value lambda do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) @@ -661,21 +660,20 @@ lvlMFE env strict_ctxt ann_expr | escapes_value_lam , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions -- See Note [Test cheapness with exprOkForSpeculation] - , Just (tc, _) <- splitTyConApp_maybe expr_ty - , Just dc <- boxingDataCon_maybe tc - , let dc_res_ty = dataConOrigResTy dc -- No free type variables - [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty] + , BI_Box { bi_data_con = box_dc, bi_inst_con = boxing_expr + , bi_boxed_type = box_ty } <- boxingDataCon expr_ty + , let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty] = do { expr1 <- lvlExpr rhs_env ann_expr ; let l1r = incMinorLvlFrom rhs_env float_rhs = mkLams abs_vars_w_lvls $ - Case expr1 (stayPut l1r ubx_bndr) dc_res_ty - [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])] + Case expr1 (stayPut l1r ubx_bndr) box_ty + [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))] ; var <- newLvlVar float_rhs Nothing is_mk_static ; let l1u = incMinorLvlFrom env use_expr = Case (mkVarApps (Var var) abs_vars) (stayPut l1u bx_bndr) expr_ty - [Alt (DataAlt dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)] + [Alt (DataAlt box_dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)] ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) use_expr) } @@ -1731,7 +1729,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) rhs_ty | otherwise - = mkSysLocal (mkFastString "lvl") uniq Many rhs_ty + = mkSysLocal (mkFastString "lvl") uniq ManyTy rhs_ty -- | Clone the binders bound by a single-alternative case. cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 400c3e60d5..a125c70c22 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -69,7 +69,6 @@ import GHC.Data.Graph.UnVar import GHC.Types.Id as Id import GHC.Core.Make ( mkWildValBinder, mkCoreLet ) import GHC.Builtin.Types -import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import qualified GHC.Core.Type as Type import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo , extendTvSubst, extendCvSubst ) @@ -503,7 +502,7 @@ mkSimplEnv mode fam_envs -- The top level "enclosing CC" is "SUBSUMED". init_in_scope :: InScopeSet -init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder Many unitTy)) +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder ManyTy unitTy)) -- See Note [WildCard binders] {- @@ -1188,7 +1187,7 @@ adjustJoinPointType mult new_res_ty join_id = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty) -- See Note [Bangs in the Simplifier] - scale_bndr (Anon af t) = Anon af $! (scaleScaled mult t) + scale_bndr (Anon t af) = (Anon $! (scaleScaled mult t)) af scale_bndr b@(Named _) = b {- Note [Scaling join point arguments] diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index 7acf31ef0d..f0e36f6fc9 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -20,6 +20,7 @@ import GHC.Driver.Flags import GHC.Core import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutBinderSwap_maybe ) @@ -604,7 +605,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co) -- See Note [OPAQUE pragma] = do { uniq <- getUniqueM ; let work_name = mkSystemVarName uniq occ_fs - work_id = mkLocalIdWithInfo work_name Many work_ty work_info + work_id = mkLocalIdWithInfo work_name ManyTy work_ty work_info is_strict = isStrictId bndr ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict @@ -831,7 +832,7 @@ makeTrivial env top_lvl dmd occ_fs expr = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr ; uniq <- getUniqueM ; let name = mkSystemVarName uniq occ_fs - var = mkLocalIdWithInfo name Many expr_ty id_info + var = mkLocalIdWithInfo name ManyTy expr_ty id_info -- Now something very like completeBind, -- but without the postInlineUnconditionally part @@ -1546,7 +1547,7 @@ In particular, we want to behave well on * (f |> co) @t1 @t2 ... @tn x1 .. xm Here we will use pushCoTyArg and pushCoValArg successively, which - build up NthCo stacks. Silly to do that if co is reflexive. + build up SelCo stacks. Silly to do that if co is reflexive. However, we don't want to call isReflexiveCo too much, because it uses type equality which is expensive on big types (#14737 comment:7). @@ -2185,7 +2186,7 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) ; return (Lam s' body') } -- Important: do not try to eta-expand this lambda -- See Note [No eta-expansion in runRW#] - _ -> do { s' <- newId (fsLit "s") Many realWorldStatePrimTy + _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy ; let (m,_,_) = splitFunTy fun_ty env' = arg_env `addNewInScopeIds` [s'] cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' @@ -3192,7 +3193,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv -- Note [Improving seq] improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") Many ty2 + = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing env2 = extendIdSubst env case_bndr rhs ; return (env2, scrut `Cast` co, case_bndr2) } diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index d67593d1bf..826c11f335 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -40,7 +40,7 @@ import GHC.Utils.Misc ( count ) import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) import Control.Monad ( ap ) -import GHC.Core.Multiplicity ( pattern Many ) +import GHC.Core.Multiplicity ( pattern ManyTy ) import GHC.Exts( oneShot ) {- @@ -221,7 +221,7 @@ newJoinId bndrs body_ty id_info = vanillaIdInfo `setArityInfo` arity -- `setOccInfo` strongLoopBreaker - ; return (mkLocalVar details name Many join_id_ty id_info) } + ; return (mkLocalVar details name ManyTy join_id_ty id_info) } {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index ae6e7ffae4..9d18365d5d 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -524,7 +524,7 @@ contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) -- should be scaled if it commutes with E. This appears, in particular, in the -- case-of-case transformation. contHoleScaling :: SimplCont -> Mult -contHoleScaling (Stop _ _ _) = One +contHoleScaling (Stop _ _ _) = OneTy contHoleScaling (CastIt _ k) = contHoleScaling k contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) = idMult id `mkMultMul` contHoleScaling k @@ -681,7 +681,7 @@ mkArgInfo env rule_base fun cont | Just (_, fun_ty') <- splitForAllTyCoVar_maybe fun_ty = add_type_strictness fun_ty' dmds -- Look through foralls - | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info + | Just (_, _, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info , dmd : rest_dmds <- dmds , let dmd' | Just Unlifted <- typeLevity_maybe arg_ty @@ -2544,7 +2544,7 @@ mkCase2 mode scrut bndr alts_ty alts _ -> True , sm_case_folding mode , Just (scrut', tx_con, mk_orig) <- caseRules (smPlatform mode) scrut - = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut') + = do { bndr' <- newId (fsLit "lwild") ManyTy (exprType scrut') ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts -- mapMaybeM: discard unreachable alternatives diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index b0a8efc1f2..fed1f32879 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -42,7 +42,7 @@ import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Predicate ( typeDeterminesValue ) import GHC.Core.Type hiding ( substTy ) -import GHC.Core.TyCon (TyCon, tyConUnique, tyConName ) +import GHC.Core.TyCon (TyCon, tyConName ) import GHC.Core.Multiplicity import GHC.Core.Ppr ( pprParendExpr ) import GHC.Core.Make ( mkImpossibleExpr ) @@ -62,6 +62,7 @@ import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.Unique.Supply import GHC.Types.Unique.FM +import GHC.Types.Unique( hasKey ) import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) import GHC.Data.Pair @@ -1136,14 +1137,13 @@ forceSpecFunTy env = any (forceSpecArgTy env) . map scaledThing . fst . splitFun forceSpecArgTy :: ScEnv -> Type -> Bool forceSpecArgTy env ty - | Just ty' <- coreView ty = forceSpecArgTy env ty' + | isFunTy ty + = False -forceSpecArgTy env ty | Just (tycon, tys) <- splitTyConApp_maybe ty - , tycon /= funTyCon - = tyConUnique tycon == specTyConKey - || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr - || any (forceSpecArgTy env) tys + = tycon `hasKey` specTyConKey + || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr + || any (forceSpecArgTy env) tys forceSpecArgTy _ _ = False @@ -1943,7 +1943,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1) spec_id = asWorkerLikeId $ - mkLocalId spec_name Many + mkLocalId spec_name ManyTy (mkLamTypes spec_lam_args spec_body_ty) -- See Note [Transfer strictness] `setIdDmdSig` spec_sig @@ -2001,7 +2001,7 @@ generaliseDictPats qvars pats , let pat_ty = exprType pat , typeDeterminesValue pat_ty , exprFreeVars pat `disjointVarSet` qvar_set - = do { id <- mkSysLocalOrCoVarM (fsLit "dict") Many pat_ty + = do { id <- mkSysLocalOrCoVarM (fsLit "dict") ManyTy pat_ty ; return (id:extra_qvs, Var id) } | otherwise = return (extra_qvs, pat) @@ -2709,7 +2709,7 @@ argToPat1 _env _in_scope _val_env arg _arg_occ arg_str -- | wildCardPats are always boring wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id]) wildCardPat ty str - = do { id <- mkSysLocalOrCoVarM (fsLit "sc") Many ty + = do { id <- mkSysLocalOrCoVarM (fsLit "sc") ManyTy ty -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id')) ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) } diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 99230b3a3b..ac4934edbf 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -31,7 +31,6 @@ import GHC.Core.Utils ( exprIsTrivial , mkCast, exprType , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs -import GHC.Core.TyCo.Rep ( TyCoBinder (..) ) import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Core.Opt.Arity( collectBindersPushingCo ) @@ -48,7 +47,7 @@ import GHC.Types.Unique.DFM import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Types.Var ( isLocalVar ) +import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id @@ -2855,8 +2854,8 @@ callInfoFVs :: CallInfoSet -> VarSet callInfoFVs (CIS _ call_info) = foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info -getTheta :: [TyCoBinder] -> [PredType] -getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder) +getTheta :: [PiTyBinder] -> [PredType] +getTheta = fmap piTyBinderType . filter isInvisiblePiTyBinder . filter isAnonPiTyBinder ------------------------------------------------------------ @@ -2905,7 +2904,7 @@ mkCallUDs' env f args -- which broadens its applicability, since rules only -- fire when saturated - mk_spec_arg :: OutExpr -> TyCoBinder -> SpecArg + mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg mk_spec_arg arg (Named bndr) | binderVar bndr `elemVarSet` constrained_tyvars = case arg of @@ -2913,19 +2912,17 @@ mkCallUDs' env f args _ -> pprPanic "ci_key" $ ppr arg | otherwise = UnspecType - -- For "InvisArg", which are the type-class dictionaries, + -- For "invisibleFunArg", which are the type-class dictionaries, -- we decide on a case by case basis if we want to specialise -- on this argument; if so, SpecDict, if not UnspecArg - mk_spec_arg arg (Anon InvisArg pred) - | interestingDict arg (scaledThing pred) + mk_spec_arg arg (Anon pred af) + | isInvisibleFunArg af + , interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg | otherwise = UnspecArg - mk_spec_arg _ (Anon VisArg _) - = UnspecArg - {- Note [Ticks on applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3347,7 +3344,7 @@ newDictBndr env@(SE { se_subst = subst }) b = do { uniq <- getUniqueM ; let n = idName b ty' = substTyUnchecked subst (idType b) - b' = mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n) + b' = mkUserLocal (nameOccName n) uniq ManyTy ty' (getSrcSpan n) env' = env { se_subst = subst `Core.extendSubstInScope` b' } ; pure (env', b') } @@ -3357,7 +3354,7 @@ newSpecIdSM old_id new_ty join_arity_maybe = do { uniq <- getUniqueM ; let name = idName old_id new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocal new_occ uniq Many new_ty (getSrcSpan name) + new_id = mkUserLocal new_occ uniq ManyTy new_ty (getSrcSpan name) `asJoinId_maybe` join_arity_maybe ; return new_id } diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index c514054ec1..c1e8a2394f 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -54,20 +54,23 @@ module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where import GHC.Prelude -import GHC.Types.Var import GHC.Core import GHC.Core.Utils import GHC.Core.Type import GHC.Core.Coercion +import GHC.Core.TyCo.Compare( eqType ) + +import GHC.Types.Var import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Unique.Supply -import GHC.Utils.Misc import GHC.Types.Unique.FM import GHC.Types.Var.Set import GHC.Types.Unique import GHC.Types.Unique.Set + +import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -420,13 +423,13 @@ saTransform binder arg_staticness rhs_binders rhs_body shadow_rhs = mkLams shadow_lam_bndrs local_body -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs - rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq Many (exprType rec_body) + rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq ManyTy (exprType rec_body) -- rec_body_bndr = sat_worker -- See Note [Shadow binding]; make a SysLocal shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) (idUnique binder) - Many + ManyTy (exprType shadow_rhs) isStaticValue :: Staticness App -> Bool diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index faedaaeec0..4e655ebb88 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -648,8 +648,8 @@ canUnboxResult fam_envs ty cpr isLinear :: Scaled a -> Bool isLinear (Scaled w _ ) = case w of - One -> True - _ -> False + OneTy -> True + _ -> False {- Note [Which types are unboxed?] @@ -1248,7 +1248,7 @@ findTypeShape fam_envs ty -- to look deep into such products -- see #18034 where go rec_tc ty - | Just (_, _, res) <- splitFunTy_maybe ty + | Just (_, _, _, res) <- splitFunTy_maybe ty = TsFun (go rec_tc res) | Just (tc, tc_args) <- splitTyConApp_maybe ty @@ -1526,7 +1526,7 @@ move_transit_vars vars (DataAlt tup_con) vars build_res , ubx_tup_app ) where - ubx_tup_app = mkCoreUbxTup (map idType vars) (map varToCoreExpr vars) + ubx_tup_app = mkCoreUnboxedTuple (map varToCoreExpr vars) tup_con = tupleDataCon Unboxed (length vars) -- See also Note [Linear types and CPR] case_bndr = mkWildValBinder cprCaseBndrMult (exprType ubx_tup_app) @@ -1655,7 +1655,7 @@ mkUnpackCase scrut co mult boxing_con unpk_args body -- | The multiplicity of a case binder unboxing a constructed result. -- See Note [Linear types and CPR] cprCaseBndrMult :: Mult -cprCaseBndrMult = One +cprCaseBndrMult = OneTy ww_prefix :: FastString ww_prefix = fsLit "ww" diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs index efcc45a772..d824076851 100644 --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -389,7 +389,7 @@ mkPatSyn :: Name -> [FieldLabel] -- ^ Names of fields for -- a record pattern synonym -> PatSyn - -- NB: The univ and ex vars are both in TyBinder form and TyVar form for + -- NB: The univ and ex vars are both in PiTyVarBinder form and TyVar form for -- convenience. All the TyBinders should be Named! mkPatSyn name declared_infix (univ_tvs, req_theta) @@ -508,6 +508,6 @@ pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta , pprType sigma_ty ] where sigma_ty = mkInvisForAllTys ex_tvs $ - mkInvisFunTysMany prov_theta $ + mkInvisFunTys prov_theta $ mkVisFunTysMany orig_args orig_res_ty insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/compiler/GHC/Core/Reduction.hs b/compiler/GHC/Core/Reduction.hs index f97b9517b6..07d7a93748 100644 --- a/compiler/GHC/Core/Reduction.hs +++ b/compiler/GHC/Core/Reduction.hs @@ -38,7 +38,7 @@ import GHC.Data.Pair ( Pair(Pair) ) import GHC.Data.List.Infinite ( Infinite (..) ) import qualified GHC.Data.List.Infinite as Inf -import GHC.Types.Var ( setTyVarKind ) +import GHC.Types.Var ( VarBndr(..), setTyVarKind ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( TyCoVarSet ) @@ -351,25 +351,25 @@ mkAppRedn (Reduction co1 ty1) (Reduction co2 ty2) -- -- Combines 'mkFunCo' and 'mkFunTy'. mkFunRedn :: Role - -> AnonArgFlag + -> FunTyFlag -> ReductionN -- ^ multiplicity reduction -> Reduction -- ^ argument reduction -> Reduction -- ^ result reduction -> Reduction -mkFunRedn r vis +mkFunRedn r af (Reduction w_co w_ty) (Reduction arg_co arg_ty) (Reduction res_co res_ty) = mkReduction - (mkFunCo r w_co arg_co res_co) - (mkFunTy vis w_ty arg_ty res_ty) + (mkFunCo1 r af w_co arg_co res_co) + (mkFunTy af w_ty arg_ty res_ty) {-# INLINE mkFunRedn #-} -- | Create a 'Reduction' associated to a Π type, -- from a kind 'Reduction' and a body 'Reduction'. -- -- Combines 'mkForAllCo' and 'mkForAllTy'. -mkForAllRedn :: ArgFlag +mkForAllRedn :: ForAllTyFlag -> TyVar -> ReductionN -- ^ kind reduction -> Reduction -- ^ body reduction @@ -377,7 +377,7 @@ mkForAllRedn :: ArgFlag mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty) = mkReduction (mkForAllCo tv1 h co) - (mkForAllTy tv2 vis ty) + (mkForAllTy (Bndr tv2 vis) ty) where tv2 = setTyVarKind tv1 ki' {-# INLINE mkForAllRedn #-} @@ -786,7 +786,7 @@ data ArgsReductions = -- This function is only called in two locations, so the amount of code duplication -- should be rather reasonable despite the size of the function. simplifyArgsWorker :: HasDebugCallStack - => [TyCoBinder] -> Kind + => [PiTyBinder] -> Kind -- the binders & result kind (not a Π-type) of the function applied to the args -- list of binders can be shorter or longer than the list of args -> TyCoVarSet -- free vars of the args @@ -811,11 +811,11 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs where orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs - go :: LiftingContext -- mapping from tyvars to rewriting coercions - -> [TyCoBinder] -- Unsubsted binders of function's kind - -> Kind -- Unsubsted result kind of function (not a Pi-type) - -> Infinite Role -- Roles at which to rewrite these ... - -> [Reduction] -- rewritten arguments, with their rewriting coercions + go :: LiftingContext -- mapping from tyvars to rewriting coercions + -> [PiTyBinder] -- Unsubsted binders of function's kind + -> Kind -- Unsubsted result kind of function (not a Pi-type) + -> Infinite Role -- Roles at which to rewrite these ... + -> [Reduction] -- rewritten arguments, with their rewriting coercions -> ArgsReductions go !lc binders inner_ki _ [] -- The !lc makes the function strict in the lifting context @@ -831,7 +831,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs go lc (binder:binders) inner_ki (Inf role roles) (arg_redn:arg_redns) = -- We rewrite an argument ty with arg_redn = Reduction arg_co arg -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2), - -- tcTypeKind(ty) = tcTypeKind(arg). + -- typeKind(ty) = typeKind(arg). -- However, it is possible that arg will be used as an argument to a function -- whose kind is different, if earlier arguments have been rewritten. -- We thus need to compose the reduction with a kind coercion to ensure @@ -839,11 +839,11 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs -- -- The bangs here have been observed to improve performance -- significantly in optimized builds; see #18502 - let !kind_co = liftCoSubst Nominal lc (tyCoBinderType binder) + let !kind_co = liftCoSubst Nominal lc (piTyBinderType binder) !(Reduction casted_co casted_xi) = mkCoherenceRightRedn role arg_redn kind_co -- now, extend the lifting context with the new binding - !new_lc | Just tv <- tyCoBinderVar_maybe binder + !new_lc | Just tv <- namedPiTyBinder_maybe binder = extendLiftingContextAndInScope lc tv casted_co | otherwise = lc diff --git a/compiler/GHC/Core/RoughMap.hs b/compiler/GHC/Core/RoughMap.hs index 87fd641e64..7107198cc6 100644 --- a/compiler/GHC/Core/RoughMap.hs +++ b/compiler/GHC/Core/RoughMap.hs @@ -13,6 +13,9 @@ module GHC.Core.RoughMap , RoughMatchLookupTc(..) , typeToRoughMatchLookupTc , roughMatchTcToLookup + , roughMatchTcs + , roughMatchTcsLookup + , instanceCantMatch -- * RoughMap , RoughMap @@ -37,11 +40,10 @@ import GHC.Core.Type import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Name.Env +import GHC.Builtin.Types.Prim( cONSTRAINTTyConName, tYPETyConName ) import Control.Monad (join) import Data.Data (Data) -import GHC.Utils.Misc -import Data.Bifunctor import GHC.Utils.Panic {- @@ -108,6 +110,10 @@ KnownTc Int, KnownTc Char]`. This explains the third clause of the mightMatch specification in Note [Simple Matching Semantics]. As soon as the lookup key runs out, the remaining instances might match. +This only matters for the data-family case of a FamInstEnv (see Note [Over-saturated matches] +in GHC.Core.FamInstEnv; it's irrelevantfor ClsInstEnv and for type-family instances. +But we use RoughMaps for all cases, so we are conservative. + Note [Matching a RoughMap] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The /lookup key/ into a rough map (RoughMatchLookupTc) is slightly @@ -135,6 +141,7 @@ an insertion key. The second case arises in two situations: doesn't match with any of the KnownTC instances so we can discard them all. For example: Show a[sk] or Show (a[sk] b[sk]). One place constraints like this arise is when typechecking derived instances. + 2. The head of the application is a known type family. For example: F a[sk]. The application of F is stuck, and because F is a type family it won't match any KnownTC instance so it's safe to discard @@ -222,20 +229,59 @@ types don't match as well. -} +{- ********************************************************************* +* * + Rough matching +* * +********************************************************************* -} + +{- Note [Rough matching in class and family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + instance C (Maybe [Tree a]) Bool +and suppose we are looking up + C Bool Bool + +We can very quickly rule the instance out, because the first +argument is headed by Maybe, whereas in the constraint we are looking +up has first argument headed by Bool. These "headed by" TyCons are +called the "rough match TyCons" of the constraint or instance. +They are used for a quick filter, to check when an instance cannot +possibly match. + +The main motivation is to avoid sucking in whole instance +declarations that are utterly useless. See GHC.Core.InstEnv +Note [ClsInst laziness and the rough-match fields]. + +INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon, +like Maybe or Either, including a newtype or a data family, both of +which are generative. It replies True to `isGenerativeTyCon tc Nominal`. + +But it is never + - A type synonym + E.g. Int and (S Bool) might match + if (S Bool) is a synonym for Int + + - A type family (#19336) + E.g. (Just a) and (F a) might match if (F a) reduces to (Just a) + albeit perhaps only after 'a' is instantiated. +-} + + -- Key for insertion into a RoughMap data RoughMatchTc - = RM_KnownTc Name -- INVARIANT: Name refers to a TyCon tc that responds - -- true to `isGenerativeTyCon tc Nominal`. See - -- Note [Rough matching in class and family instances] - | RM_WildCard -- e.g. type variable at the head + = RM_KnownTc Name -- INVARIANT: Name refers to a TyCon tc that responds + -- true to `isGenerativeTyCon tc Nominal`. See + -- Note [Rough matching in class and family instances] + | RM_WildCard -- e.g. type variable at the head deriving( Data ) -- Key for lookup into a RoughMap -- See Note [Matching a RoughMap] data RoughMatchLookupTc = RML_KnownTc Name -- ^ The position only matches the specified KnownTc - | RML_NoKnownTc -- ^ The position definitely doesn't match any KnownTc - | RML_WildCard -- ^ The position can match anything + | RML_NoKnownTc -- ^ The position definitely doesn't match any KnownTc + | RML_WildCard -- ^ The position can match anything deriving ( Data ) instance Outputable RoughMatchLookupTc where @@ -243,31 +289,51 @@ instance Outputable RoughMatchLookupTc where ppr RML_NoKnownTc = text "RML_NoKnownTC" ppr RML_WildCard = text "_" -roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc -roughMatchTcToLookup (RM_KnownTc n) = RML_KnownTc n -roughMatchTcToLookup RM_WildCard = RML_WildCard - instance Outputable RoughMatchTc where ppr (RM_KnownTc nm) = text "KnownTc" <+> ppr nm ppr RM_WildCard = text "OtherTc" +instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- possibly be instantiated to actual, nor vice versa; +-- False is non-committal +instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as +instanceCantMatch _ _ = False -- Safe + +itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool +itemCantMatch (RM_KnownTc t) (RM_KnownTc a) = t /= a +itemCantMatch _ _ = False + +roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc +roughMatchTcToLookup (RM_KnownTc n) = RML_KnownTc n +roughMatchTcToLookup RM_WildCard = RML_WildCard + isRoughWildcard :: RoughMatchTc -> Bool isRoughWildcard RM_WildCard = True isRoughWildcard (RM_KnownTc {}) = False +roughMatchTcs :: [Type] -> [RoughMatchTc] +roughMatchTcs tys = map typeToRoughMatchTc tys + +roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc] +roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys + typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc typeToRoughMatchLookupTc ty - | Just (ty', _) <- splitCastTy_maybe ty = typeToRoughMatchLookupTc ty' - | otherwise = - case splitAppTys ty of + | Just (ty', _) <- splitCastTy_maybe ty + = typeToRoughMatchLookupTc ty' + | otherwise + = case splitAppTys ty of -- Case 1: Head of application is a type variable, does not match any KnownTc. (TyVarTy {}, _) -> RML_NoKnownTc + (TyConApp tc _, _) -- Case 2: Head of application is a known type constructor, hence KnownTc. - | not (isTypeFamilyTyCon tc) -> RML_KnownTc $! tyConName tc + | not (isTypeFamilyTyCon tc) -> RML_KnownTc $! roughMatchTyConName tc -- Case 3: Head is a type family so it's stuck and therefore doesn't match -- any KnownTc | isTypeFamilyTyCon tc -> RML_NoKnownTc + -- Fallthrough: Otherwise, anything might match this position _ -> RML_WildCard @@ -275,11 +341,23 @@ typeToRoughMatchTc :: Type -> RoughMatchTc typeToRoughMatchTc ty | Just (ty', _) <- splitCastTy_maybe ty = typeToRoughMatchTc ty' | Just (tc,_) <- splitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) - RM_KnownTc $! tyConName tc + , not (isTypeFamilyTyCon tc) = RM_KnownTc $! roughMatchTyConName tc -- See Note [Rough matching in class and family instances] | otherwise = RM_WildCard +roughMatchTyConName :: TyCon -> Name +roughMatchTyConName tc + | tc_name == cONSTRAINTTyConName + = tYPETyConName -- TYPE and CONSTRAINT are not apart, so they must use + -- the same rough-map key. We arbitrarily use TYPE. + -- See Note [Type and Constraint are not apart] + -- wrinkle (W1) in GHC.Builtin.Types.Prim + | otherwise + = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) tc_name + where + tc_name = tyConName tc + + -- | Trie of @[RoughMatchTc]@ -- -- *Examples* @@ -288,14 +366,20 @@ typeToRoughMatchTc ty -- insert [OtherTc] 2 -- lookup [OtherTc] == [1,2] -- @ -data RoughMap a = RM { rm_empty :: Bag a - , rm_known :: DNameEnv (RoughMap a) - -- See Note [InstEnv determinism] in GHC.Core.InstEnv - , rm_unknown :: RoughMap a } - | RMEmpty -- an optimised (finite) form of emptyRM - -- invariant: Empty RoughMaps are always represented with RMEmpty +data RoughMap a + = RMEmpty -- An optimised (finite) form of emptyRM + -- Invariant: Empty RoughMaps are always represented with RMEmpty + + | RM { rm_empty :: Bag a + -- Keyed by an empty [RoughMapTc] + + , rm_known :: DNameEnv (RoughMap a) + -- Keyed by (RM_KnownTc tc : rm_tcs) + -- DNameEnv: see Note [InstEnv determinism] in GHC.Core.InstEnv - deriving (Functor) + , rm_wild :: RoughMap a } + -- Keyed by (RM_WildCard : rm_tcs) + deriving (Functor) instance Outputable a => Outputable (RoughMap a) where ppr (RM empty known unknown) = @@ -323,28 +407,37 @@ lookupRM tcs rm = bagToList (fst $ lookupRM' tcs rm) -- See Note [Matches vs Unifiers] lookupRM' :: [RoughMatchLookupTc] -> RoughMap a -> (Bag a -- Potential matches , [a]) -- Potential unifiers -lookupRM' _ RMEmpty = (emptyBag, []) --- See Note [Simple Matching Semantics] about why we return everything when the lookup --- key runs out. -lookupRM' [] rm = let m = elemsRM rm - in (listToBag m, m) +lookupRM' _ RMEmpty -- The RoughMap is empty + = (emptyBag, []) + +lookupRM' [] rm -- See Note [Simple Matching Semantics] about why + = (listToBag m, m) -- we return everything when the lookup key runs out + where + m = elemsRM rm + lookupRM' (RML_KnownTc tc : tcs) rm = - let (common_m, common_u) = lookupRM' tcs (rm_unknown rm) + let (common_m, common_u) = lookupRM' tcs (rm_wild rm) (m, u) = maybe (emptyBag, []) (lookupRM' tcs) (lookupDNameEnv (rm_known rm) tc) - in (rm_empty rm `unionBags` common_m `unionBags` m + in ( rm_empty rm `unionBags` common_m `unionBags` m , bagToList (rm_empty rm) ++ common_u ++ u) --- A RML_NoKnownTC does **not** match any KnownTC but can unify -lookupRM' (RML_NoKnownTc : tcs) rm = - let (u_m, _u_u) = lookupRM' tcs (rm_unknown rm) - in (rm_empty rm `unionBags` u_m -- Definitely don't match +-- A RML_NoKnownTC does **not** match any KnownTC but can unify +lookupRM' (RML_NoKnownTc : tcs) rm = + let (u_m, _u_u) = lookupRM' tcs (rm_wild rm) + in ( rm_empty rm `unionBags` u_m -- Definitely don't match , snd $ lookupRM' (RML_WildCard : tcs) rm) -- But could unify.. lookupRM' (RML_WildCard : tcs) rm = - let (m, u) = bimap unionManyBags concat (mapAndUnzip (lookupRM' tcs) (eltsDNameEnv $ rm_known rm)) - (u_m, u_u) = lookupRM' tcs (rm_unknown rm) - in (rm_empty rm `unionBags` u_m `unionBags` m - , bagToList (rm_empty rm) ++ u_u ++ u) +-- pprTrace "RM wild" (ppr tcs $$ ppr (eltsDNameEnv (rm_known rm))) $ + let (m, u) = foldDNameEnv add_one (emptyBag, []) (rm_known rm) + (u_m, u_u) = lookupRM' tcs (rm_wild rm) + in ( rm_empty rm `unionBags` u_m `unionBags` m + , bagToList (rm_empty rm) ++ u_u ++ u ) + where + add_one :: RoughMap a -> (Bag a, [a]) -> (Bag a, [a]) + add_one rm ~(m2, u2) = (m1 `unionBags` m2, u1 ++ u2) + where + (m1,u1) = lookupRM' tcs rm unionRM :: RoughMap a -> RoughMap a -> RoughMap a unionRM RMEmpty a = a @@ -352,7 +445,7 @@ unionRM a RMEmpty = a unionRM a b = RM { rm_empty = rm_empty a `unionBags` rm_empty b , rm_known = plusDNameEnv_C unionRM (rm_known a) (rm_known b) - , rm_unknown = rm_unknown a `unionRM` rm_unknown b + , rm_wild = rm_wild a `unionRM` rm_wild b } @@ -360,17 +453,19 @@ insertRM :: [RoughMatchTc] -> a -> RoughMap a -> RoughMap a insertRM k v RMEmpty = insertRM k v $ RM { rm_empty = emptyBag , rm_known = emptyDNameEnv - , rm_unknown = emptyRM } + , rm_wild = emptyRM } insertRM [] v rm@(RM {}) = -- See Note [Simple Matching Semantics] rm { rm_empty = v `consBag` rm_empty rm } + insertRM (RM_KnownTc k : ks) v rm@(RM {}) = rm { rm_known = alterDNameEnv f (rm_known rm) k } where f Nothing = Just $ (insertRM ks v emptyRM) f (Just m) = Just $ (insertRM ks v m) + insertRM (RM_WildCard : ks) v rm@(RM {}) = - rm { rm_unknown = insertRM ks v (rm_unknown rm) } + rm { rm_wild = insertRM ks v (rm_wild rm) } filterRM :: (a -> Bool) -> RoughMap a -> RoughMap a filterRM _ RMEmpty = RMEmpty @@ -378,7 +473,7 @@ filterRM pred rm = normalise $ RM { rm_empty = filterBag pred (rm_empty rm), rm_known = mapDNameEnv (filterRM pred) (rm_known rm), - rm_unknown = filterRM pred (rm_unknown rm) + rm_wild = filterRM pred (rm_wild rm) } -- | Place a 'RoughMap' in normal form, turning all empty 'RM's into @@ -399,13 +494,13 @@ filterMatchingRM pred (RM_KnownTc tc : tcs) rm = normalise $ RM { rm_empty = filterBag pred (rm_empty rm), rm_known = alterDNameEnv (join . fmap (dropEmpty . filterMatchingRM pred tcs)) (rm_known rm) tc, - rm_unknown = filterMatchingRM pred tcs (rm_unknown rm) + rm_wild = filterMatchingRM pred tcs (rm_wild rm) } filterMatchingRM pred (RM_WildCard : tcs) rm = normalise $ RM { rm_empty = filterBag pred (rm_empty rm), rm_known = mapDNameEnv (filterMatchingRM pred tcs) (rm_known rm), - rm_unknown = filterMatchingRM pred tcs (rm_unknown rm) + rm_wild = filterMatchingRM pred tcs (rm_wild rm) } dropEmpty :: RoughMap a -> Maybe (RoughMap a) @@ -421,7 +516,7 @@ foldRM f = go -- N.B. local worker ensures that the loop can be specialised to the fold -- function. go z RMEmpty = z - go z (RM{ rm_unknown = unk, rm_known = known, rm_empty = empty}) = + go z (RM{ rm_wild = unk, rm_known = known, rm_empty = empty}) = foldr f (foldDNameEnv @@ -442,7 +537,7 @@ nonDetStrictFoldRM f = go f (nonDetStrictFoldDNameEnv (flip go) - (go z (rm_unknown rm)) + (go z (rm_wild rm)) (rm_known rm) ) (rm_empty rm) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index d8f2b4b5bd..5638762e08 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -1225,7 +1225,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr -- Good: returning (Mk#, [x]) with a float of case exp of x { DEFAULT -> [] } -- simplifier produces case exp of a { DEFAULT -> exp[x/a] } = let arg' = subst_expr subst arg - bndr = uniqAway (subst_in_scope subst) (mkWildValBinder Many arg_type) + bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type) float = FloatCase arg' bndr DEFAULT [] subst' = subst_extend_in_scope subst bndr in go subst' (float:floats) fun (CC (Var bndr : args) co) diff --git a/compiler/GHC/Core/TyCo/Compare.hs b/compiler/GHC/Core/TyCo/Compare.hs new file mode 100644 index 0000000000..4ef9d04eb8 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Compare.hs @@ -0,0 +1,584 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1998 + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} + +-- | Type equality and comparison +module GHC.Core.TyCo.Compare ( + + -- * Type comparison + eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, + nonDetCmpTypesX, nonDetCmpTc, + eqVarBndrs, + + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + tcEqTyConApps, + + -- * Visiblity comparision + eqForAllVis, cmpForAllVis + + ) where + +import GHC.Prelude + +import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCon + +import GHC.Types.Var +import GHC.Types.Unique +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import GHC.Base (reallyUnsafePtrEquality#) + +import qualified Data.Semigroup as S + +{- GHC.Core.TyCo.Compare overview +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module implements type equality and comparison + +It uses a few functions from GHC.Core.Type, notably `typeKind`, +so it currently sits "on top of" GHC.Core.Type. +-} + +{- ********************************************************************* +* * + Type equality +* * +********************************************************************* -} + +{- Note [Computing equality on types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module implements type equality, notably `eqType`. This is +"definitional equality" or just "equality" for short. + +There are several places within GHC that depend on the precise choice of +definitional equality used. If we change that definition, all these places +must be updated. This Note merely serves as a place for all these places +to refer to, so searching for references to this Note will find every place +that needs to be updated. + +* See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. + +* See Historical Note [Typechecker equality vs definitional equality] + below + +Note [Type comparisons using object pointer comparisons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Quite often we substitute the type from a definition site into +occurances without a change. This means for code like: + \x -> (x,x,x) +The type of every `x` will often be represented by a single object +in the heap. We can take advantage of this by shortcutting the equality +check if two types are represented by the same pointer under the hood. +In some cases this reduces compiler allocations by ~2%. +-} + + +tcEqKind :: HasDebugCallStack => Kind -> Kind -> Bool +tcEqKind = tcEqType + +tcEqType :: HasDebugCallStack => Type -> Type -> Bool +-- ^ tcEqType implements typechecker equality +-- It behaves just like eqType, but is implemented +-- differently (for now) +tcEqType ty1 ty2 + = tcEqTypeNoSyns ki1 ki2 + && tcEqTypeNoSyns ty1 ty2 + where + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +-- | Just like 'tcEqType', but will return True for types of different kinds +-- as long as their non-coercion structure is identical. +tcEqTypeNoKindCheck :: Type -> Type -> Bool +tcEqTypeNoKindCheck ty1 ty2 + = tcEqTypeNoSyns ty1 ty2 + +-- | Check whether two TyConApps are the same; if the number of arguments +-- are different, just checks the common prefix of arguments. +tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool +tcEqTyConApps tc1 args1 tc2 args2 + = tc1 == tc2 && + and (zipWith tcEqTypeNoKindCheck args1 args2) + -- No kind check necessary: if both arguments are well typed, then + -- any difference in the kinds of later arguments would show up + -- as differences in earlier (dependent) arguments + +{- +Note [Specialising tc_eq_type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type equality predicates in Type are hit pretty hard during typechecking. +Consequently we take pains to ensure that these paths are compiled to +efficient, minimally-allocating code. + +To this end we place an INLINE on tc_eq_type, ensuring that it is inlined into +its publicly-visible interfaces (e.g. tcEqType). In addition to eliminating +some dynamic branches, this allows the simplifier to eliminate the closure +allocations that would otherwise be necessary to capture the two boolean "mode" +flags. This reduces allocations by a good fraction of a percent when compiling +Cabal. + +See #19226. +-} + +-- | Type equality comparing both visible and invisible arguments and expanding +-- type synonyms. +tcEqTypeNoSyns :: Type -> Type -> Bool +tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb + +-- | Like 'tcEqType', but returns True if the /visible/ part of the types +-- are equal, even if they are really unequal (in the invisible bits) +tcEqTypeVis :: Type -> Type -> Bool +tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 + +-- | Like 'pickyEqTypeVis', but returns a Bool for convenience +pickyEqType :: Type -> Type -> Bool +-- Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +-- This ignores kinds and coercions, because this is used only for printing. +pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 + +-- | Real worker for 'tcEqType'. No kind check! +tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms + -> Bool -- ^ True <=> compare visible args only + -> Type -> Type + -> Bool +-- Flags False, False is the usual setting for tc_eq_type +-- See Note [Computing equality on types] in Type +tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 + = go orig_env orig_ty1 orig_ty2 + where + go :: RnEnv2 -> Type -> Type -> Bool + -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. + go _ (TyConApp tc1 []) (TyConApp tc2 []) + | tc1 == tc2 + = True + + go env t1 t2 | not keep_syns, Just t1' <- coreView t1 = go env t1' t2 + go env t1 t2 | not keep_syns, Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = rnOccL env tv1 == rnOccR env tv2 + + go _ (LitTy lit1) (LitTy lit2) + = lit1 == lit2 + + go env (ForAllTy (Bndr tv1 vis1) ty1) + (ForAllTy (Bndr tv2 vis2) ty2) + = vis1 `eqForAllVis` vis2 + && (vis_only || go env (varType tv1) (varType tv2)) + && go (rnBndr2 env tv1 tv2) ty1 ty2 + + -- Make sure we handle all FunTy cases since falling through to the + -- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked + -- kind variable, which causes things to blow up. + -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check + -- kinds here + go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) + = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2 + where + kinds_eq | vis_only = True + | otherwise = go env (typeKind arg1) (typeKind arg2) && + go env (typeKind res1) (typeKind res2) + + -- See Note [Equality on AppTys] in GHC.Core.Type + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2 + = go env s1 s2 && go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1 + = go env s1 s2 && go env t1 t2 + + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 + + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True + + go _ _ _ = False + + gos _ _ [] [] = True + gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) + && gos env igs ts1 ts2 + gos _ _ _ _ = False + + tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore + tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles + | otherwise = repeat False -- Ignore nothing + -- The repeat False is necessary because tycons + -- can legitimately be oversaturated + where + bndrs = tyConBinders tc + inviss = map isInvisibleTyConBinder bndrs + + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + +{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. + + +-- | Do these denote the same level of visibility? 'Required' +-- arguments are visible, others are not. So this function +-- equates 'Specified' and 'Inferred'. Used for printing. +eqForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Bool +-- See Note [ForAllTy and type equality] +-- If you change this, see IMPORTANT NOTE in the above Note +eqForAllVis Required Required = True +eqForAllVis (Invisible _) (Invisible _) = True +eqForAllVis _ _ = False + +-- | Do these denote the same level of visibility? 'Required' +-- arguments are visible, others are not. So this function +-- equates 'Specified' and 'Inferred'. Used for printing. +cmpForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Ordering +-- See Note [ForAllTy and type equality] +-- If you change this, see IMPORTANT NOTE in the above Note +cmpForAllVis Required Required = EQ +cmpForAllVis Required (Invisible {}) = LT +cmpForAllVis (Invisible _) Required = GT +cmpForAllVis (Invisible _) (Invisible _) = EQ + + +{- Note [ForAllTy and type equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we compare (ForAllTy (Bndr tv1 vis1) ty1) + and (ForAllTy (Bndr tv2 vis2) ty2) +what should we do about `vis1` vs `vis2`. + +First, we always compare with `eqForAllVis` and `cmpForAllVis`. +But what decision do we make? + +Should GHC type-check the following program (adapted from #15740)? + + {-# LANGUAGE PolyKinds, ... #-} + data D a + type family F :: forall k. k -> Type + type instance F = D + +Due to the way F is declared, any instance of F must have a right-hand side +whose kind is equal to `forall k. k -> Type`. The kind of D is +`forall {k}. k -> Type`, which is very close, but technically uses distinct +Core: + + ----------------------------------------------------------- + | Source Haskell | Core | + ----------------------------------------------------------- + | forall k. <...> | ForAllTy (Bndr k Specified) (<...>) | + | forall {k}. <...> | ForAllTy (Bndr k Inferred) (<...>) | + ----------------------------------------------------------- + +We could deem these kinds to be unequal, but that would imply rejecting +programs like the one above. Whether a kind variable binder ends up being +specified or inferred can be somewhat subtle, however, especially for kinds +that aren't explicitly written out in the source code (like in D above). + +For now, we decide + + the specified/inferred status of an invisible type variable binder + does not affect GHC's notion of equality. + +That is, we have the following: + + -------------------------------------------------- + | Type 1 | Type 2 | Equal? | + --------------------|----------------------------- + | forall k. <...> | forall k. <...> | Yes | + | | forall {k}. <...> | Yes | + | | forall k -> <...> | No | + -------------------------------------------------- + | forall {k}. <...> | forall k. <...> | Yes | + | | forall {k}. <...> | Yes | + | | forall k -> <...> | No | + -------------------------------------------------- + | forall k -> <...> | forall k. <...> | No | + | | forall {k}. <...> | No | + | | forall k -> <...> | Yes | + -------------------------------------------------- + +IMPORTANT NOTE: if we want to change this decision, ForAllCo will need to carry +visiblity (by taking a ForAllTyBinder rathre than a TyCoVar), so that +coercionLKind/RKind build forall types that match (are equal to) the desired +ones. Otherwise we get an infinite loop in the solver via canEqCanLHSHetero. +Examples: T16946, T15079. + +Historical Note [Typechecker equality vs definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes some history, in case there are vesitges of this +history lying around in the code. + +Summary: prior to summer 2022, GHC had have two notions of equality +over Core types. But now there is only one: definitional equality, +or just equality for short. + +The old setup was: + +* Definitional equality, as implemented by GHC.Core.Type.eqType. + See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. + +* Typechecker equality, as implemented by tcEqType. + GHC.Tc.Solver.Canonical.canEqNC also respects typechecker equality. + +Typechecker equality implied definitional equality: if two types are equal +according to typechecker equality, then they are also equal according to +definitional equality. The converse is not always true, as typechecker equality +is more finer-grained than definitional equality in two places: + +* Constraint vs Type. Definitional equality equated Type and + Constraint, but typechecker treats them as distinct types. + +* Unlike definitional equality, which does not care about the ForAllTyFlag of a + ForAllTy, typechecker equality treats Required type variable binders as + distinct from Invisible type variable binders. + See Note [ForAllTy and type equality] + + +************************************************************************ +* * + Comparison for types + (We don't use instances so that we know where it happens) +* * +************************************************************************ + +Note [Equality on AppTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In our cast-ignoring equality, we want to say that the following two +are equal: + + (Maybe |> co) (Int |> co') ~? Maybe Int + +But the left is an AppTy while the right is a TyConApp. The solution is +to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and +then continue. Easy to do, but also easy to forget to do. + +Note [Comparing nullary type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the task of testing equality between two 'Type's of the form + + TyConApp tc [] + +where @tc@ is a type synonym. A naive way to perform this comparison these +would first expand the synonym and then compare the resulting expansions. + +However, this is obviously wasteful and the RHS of @tc@ may be large; it is +much better to rather compare the TyCons directly. Consequently, before +expanding type synonyms in type comparisons we first look for a nullary +TyConApp and simply compare the TyCons if we find one. Of course, if we find +that the TyCons are *not* equal then we still need to perform the expansion as +their RHSs may still be equal. + +We perform this optimisation in a number of places: + + * GHC.Core.Types.eqType + * GHC.Core.Types.nonDetCmpType + * GHC.Core.Unify.unify_ty + * TcCanonical.can_eq_nc' + * TcUnify.uType + +This optimisation is especially helpful for the ubiquitous GHC.Types.Type, +since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications +whenever possible. See Note [Using synonyms to compress types] in +GHC.Core.Type for details. + +-} + +eqType :: Type -> Type -> Bool +-- ^ Type equality on source types. Does not look through @newtypes@, +-- 'PredType's or type families, but it does look through type synonyms. +-- This first checks that the kinds of the types are equal and then +-- checks whether the types are equal, ignoring casts and coercions. +-- (The kind check is a recursive call, but since all kinds have type +-- @Type@, there is no need to check the types of kinds.) +-- See also Note [Non-trivial definitional equality] in "GHC.Core.TyCo.Rep". +eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 + -- It's OK to use nonDetCmpType here and eqType is deterministic, + -- nonDetCmpType does equality deterministically + +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 + -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, + -- nonDetCmpTypeX does equality deterministically + +-- | Type equality on lists of types, looking through type synonyms +-- but not newtypes. +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 + -- It's OK to use nonDetCmpType here and eqTypes is deterministic, + -- nonDetCmpTypes does equality deterministically + +eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 +-- Check that the var lists are the same length +-- and have matching kinds; if so, extend the RnEnv2 +-- Returns Nothing if they don't match +eqVarBndrs env [] [] + = Just env +eqVarBndrs env (tv1:tvs1) (tv2:tvs2) + | eqTypeX env (varType tv1) (varType tv2) + = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqVarBndrs _ _ _= Nothing + +-- Now here comes the real worker + +{- +Note [nonDetCmpType nondeterminism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX +uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for +ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, +comparing type variables is nondeterministic, note the call to nonDetCmpVar in +nonDetCmpTypeX. +See Note [Unique Determinism] for more details. +-} + +nonDetCmpType :: Type -> Type -> Ordering +nonDetCmpType !t1 !t2 + -- See Note [Type comparisons using object pointer comparisons] + | 1# <- reallyUnsafePtrEquality# t1 t2 + = EQ +nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 + = EQ +nonDetCmpType t1 t2 + -- we know k1 and k2 have the same kind, because they both have kind *. + = nonDetCmpTypeX rn_env t1 t2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) +{-# INLINE nonDetCmpType #-} + +nonDetCmpTypes :: [Type] -> [Type] -> Ordering +nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) + +-- | An ordering relation between two 'Type's (known below as @t1 :: k1@ +-- and @t2 :: k2@) +data TypeOrdering = TLT -- ^ @t1 < t2@ + | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, + -- therefore we can conclude @k1 ~ k2@ + | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so + -- they may differ in kind. + | TGT -- ^ @t1 > t2@ + deriving (Eq, Ord, Enum, Bounded) + +nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + -- See Note [Computing equality on types] +nonDetCmpTypeX env orig_t1 orig_t2 = + case go env orig_t1 orig_t2 of + -- If there are casts then we also need to do a comparison of + -- the kinds of the types being compared + TEQX -> toOrdering $ go env k1 k2 + ty_ordering -> toOrdering ty_ordering + where + k1 = typeKind orig_t1 + k2 = typeKind orig_t2 + + toOrdering :: TypeOrdering -> Ordering + toOrdering TLT = LT + toOrdering TEQ = EQ + toOrdering TEQX = EQ + toOrdering TGT = GT + + liftOrdering :: Ordering -> TypeOrdering + liftOrdering LT = TLT + liftOrdering EQ = TEQ + liftOrdering GT = TGT + + thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering + thenCmpTy TEQ rel = rel + thenCmpTy TEQX rel = hasCast rel + thenCmpTy rel _ = rel + + hasCast :: TypeOrdering -> TypeOrdering + hasCast TEQ = TEQX + hasCast rel = rel + + -- Returns both the resulting ordering relation between + -- the two types and whether either contains a cast. + go :: RnEnv2 -> Type -> Type -> TypeOrdering + -- See Note [Comparing nullary type synonyms]. + go _ (TyConApp tc1 []) (TyConApp tc2 []) + | tc1 == tc2 + = TEQ + go env t1 t2 + | Just t1' <- coreView t1 = go env t1' t2 + | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 + go env (ForAllTy (Bndr tv1 vis1) t1) (ForAllTy (Bndr tv2 vis2) t2) + = liftOrdering (vis1 `cmpForAllVis` vis2) + `thenCmpTy` go env (varType tv1) (varType tv2) + `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 + + -- See Note [Equality on AppTys] + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- splitAppTyNoView_maybe ty2 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- splitAppTyNoView_maybe ty1 + = go env s1 s2 `thenCmpTy` go env t1 t2 + + go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) + -- NB: nonDepCmpTypeX does the kind check requested by + -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep + = liftOrdering (nonDetCmpTypeX env s1 s2 S.<> nonDetCmpTypeX env t1 t2) + `thenCmpTy` go env w1 w2 + -- Comparing multiplicities last because the test is usually true + + go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) + = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 + + go _ (LitTy l1) (LitTy l2) = liftOrdering (nonDetCmpTyLit l1 l2) + go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 + go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 + + go _ (CoercionTy {}) (CoercionTy {}) = TEQ + + -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy + go _ ty1 ty2 + = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) + where get_rank :: Type -> Int + get_rank (CastTy {}) + = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) + get_rank (TyVarTy {}) = 0 + get_rank (CoercionTy {}) = 1 + get_rank (AppTy {}) = 3 + get_rank (LitTy {}) = 4 + get_rank (TyConApp {}) = 5 + get_rank (FunTy {}) = 6 + get_rank (ForAllTy {}) = 7 + + gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering + gos _ [] [] = TEQ + gos _ [] _ = TLT + gos _ _ [] = TGT + gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 + +------------- +nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering +nonDetCmpTypesX _ [] [] = EQ +nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 S.<> + nonDetCmpTypesX env tys1 tys2 +nonDetCmpTypesX _ [] _ = LT +nonDetCmpTypesX _ _ [] = GT + +------------- +-- | Compare two 'TyCon's. +-- See Note [nonDetCmpType nondeterminism] +nonDetCmpTc :: TyCon -> TyCon -> Ordering +nonDetCmpTc tc1 tc2 + = u1 `nonDetCmpUnique` u2 + where + u1 = tyConUnique tc1 + u2 = tyConUnique tc2 + + + diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs index 366f3b8efe..3685876fa4 100644 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -30,6 +30,15 @@ module GHC.Core.TyCo.FVs anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo, noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, + -- * Free type constructors + tyConsOfType, + + -- * Free vars with visible/invisible separate + visVarsOfTypes, visVarsOfType, + + -- * Occurrence-check expansion + occCheckExpand, + -- * Well-scoped free variables scopedSort, tyCoVarsOfTypeWellScoped, tyCoVarsOfTypesWellScoped, @@ -44,19 +53,26 @@ module GHC.Core.TyCo.FVs import GHC.Prelude -import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) +import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView ) +import {-# SOURCE #-} GHC.Core.Coercion( coercionLKind ) + +import GHC.Builtin.Types.Prim( funTyFlagTyCon ) import Data.Monoid as DM ( Endo(..), Any(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon -import GHC.Types.Var +import GHC.Core.Coercion.Axiom( coAxiomTyCon ) import GHC.Utils.FV +import GHC.Types.Var import GHC.Types.Unique.FM +import GHC.Types.Unique.Set + import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Data.Pair {- %************************************************************************ @@ -575,7 +591,7 @@ tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfT tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc -tyCoFVsBndr :: TyCoVarBinder -> FV -> FV +tyCoFVsBndr :: ForAllTyBinder -> FV -> FV -- Free vars of (forall b. <thing with fvs>) tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs @@ -617,7 +633,7 @@ tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc -tyCoFVsOfCo (FunCo _ w co1 co2) fv_cand in_scope acc +tyCoFVsOfCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc = tyCoFVsOfCoVar v fv_cand in_scope acc @@ -630,7 +646,7 @@ tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc -tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (SelCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc @@ -673,8 +689,8 @@ almost_devoid_co_var_of_co (AppCo co arg) cv almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv = almost_devoid_co_var_of_co kind_co cv && (v == cv || almost_devoid_co_var_of_co co cv) -almost_devoid_co_var_of_co (FunCo _ w co1 co2) cv - = almost_devoid_co_var_of_co w cv +almost_devoid_co_var_of_co (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) cv + = almost_devoid_co_var_of_co w cv && almost_devoid_co_var_of_co co1 cv && almost_devoid_co_var_of_co co2 cv almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv @@ -690,7 +706,7 @@ almost_devoid_co_var_of_co (SymCo co) cv almost_devoid_co_var_of_co (TransCo co1 co2) cv = almost_devoid_co_var_of_co co1 cv && almost_devoid_co_var_of_co co2 cv -almost_devoid_co_var_of_co (NthCo _ _ co) cv +almost_devoid_co_var_of_co (SelCo _ co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co (LRCo _ co) cv = almost_devoid_co_var_of_co co cv @@ -747,6 +763,43 @@ almost_devoid_co_var_of_types (ty:tys) cv +{- +%************************************************************************ +%* * + Free tyvars, but with visible/invisible info +%* * +%************************************************************************ + +-} +-- | Retrieve the free variables in this type, splitting them based +-- on whether they are used visibly or invisibly. Invisible ones come +-- first. +visVarsOfType :: Type -> Pair TyCoVarSet +visVarsOfType orig_ty = Pair invis_vars vis_vars + where + Pair invis_vars1 vis_vars = go orig_ty + invis_vars = invis_vars1 `minusVarSet` vis_vars + + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp tc tys) = go_tc tc tys + go (FunTy _ w t1 t2) = go w `mappend` go t1 `mappend` go t2 + go (ForAllTy (Bndr tv _) ty) + = ((`delVarSet` tv) <$> go ty) `mappend` + (invisible (tyCoVarsOfType $ varType tv)) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) + go (CoercionTy co) = invisible $ tyCoVarsOfCo co + + invisible vs = Pair vs emptyVarSet + + go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in + invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis + +visVarsOfTypes :: [Type] -> Pair TyCoVarSet +visVarsOfTypes = foldMap visVarsOfType + + {- ********************************************************************* * * Injective free vars @@ -833,7 +886,7 @@ injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under -- * In the kind of a bound variable in a forall -- * In a coercion -- * In a Specified or Inferred argument to a function --- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" +-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" invisibleVarsOfType :: Type -> FV invisibleVarsOfType = go where @@ -996,3 +1049,273 @@ tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList -- | Get the free vars of types in scoped order tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList + +{- +************************************************************************ +* * + Free type constructors +* * +************************************************************************ +-} + +-- | All type constructors occurring in the type; looking through type +-- synonyms, but not newtypes. +-- When it finds a Class, it returns the class TyCon. +tyConsOfType :: Type -> UniqSet TyCon +tyConsOfType ty + = go ty + where + go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy {}) = emptyUniqSet + go (LitTy {}) = emptyUniqSet + go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys + go (AppTy a b) = go a `unionUniqSets` go b + go (FunTy af w a b) = go w `unionUniqSets` + go a `unionUniqSets` go b + `unionUniqSets` go_tc (funTyFlagTyCon af) + go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) + go (CastTy ty co) = go ty `unionUniqSets` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco + go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args + go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co + go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r }) + = go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r + go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args + go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 + go_co (CoVarCo {}) = emptyUniqSet + go_co (HoleCo {}) = emptyUniqSet + go_co (SymCo co) = go_co co + go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (SelCo _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_mco MRefl = emptyUniqSet + go_mco (MCo co) = go_co co + + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyUniqSet + go_prov (CorePrepProv _) = emptyUniqSet + -- this last case can happen from the tyConsOfType used from + -- checkTauTvUpdate + + go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys + go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos + + go_tc tc = unitUniqSet tc + go_ax ax = go_tc $ coAxiomTyCon ax + + +{- ********************************************************************** +* * + Occurs check expansion +%* * +%********************************************************************* -} + +{- Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + +For example, suppose we have + type F a b = [a] +Then + occCheckExpand b (F Int b) = Just [Int] +but + occCheckExpand a (F a Int) = Nothing + +We don't promise to do the absolute minimum amount of expanding +necessary, but we try not to do expansions we don't need to. We +prefer doing inner expansions first. For example, + type F a b = (a, Int, a, [a]) + type G b = Char +We have + occCheckExpand b (F (G b)) = Just (F Char) +even though we could also expand F to get rid of b. + +Note [Occurrence checking: look inside kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are considering unifying + (alpha :: *) ~ Int -> (beta :: alpha -> alpha) +This may be an error (what is that alpha doing inside beta's kind?), +but we must not make the mistake of actually unifying or we'll +build an infinite data structure. So when looking for occurrences +of alpha in the rhs, we must look in the kinds of type variables +that occur there. + +occCheckExpand tries to expand type synonyms to remove +unnecessary occurrences of a variable, and thereby get past an +occurs-check failure. This is good; but + we can't do it in the /kind/ of a variable /occurrence/ + +For example #18451 built an infinite type: + type Const a b = a + data SameKind :: k -> k -> Type + type T (k :: Const Type a) = forall (b :: k). SameKind a b + +We have + b :: k + k :: Const Type a + a :: k (must be same as b) + +So if we aren't careful, a's kind mentions a, which is bad. +And expanding an /occurrence/ of 'a' doesn't help, because the +/binding site/ is the master copy and all the occurrences should +match it. + +Here's a related example: + f :: forall a b (c :: Const Type b). Proxy '[a, c] + +The list means that 'a' gets the same kind as 'c'; but that +kind mentions 'b', so the binders are out of order. + +Bottom line: in occCheckExpand, do not expand inside the kinds +of occurrences. See bad_var_occ in occCheckExpand. And +see #18451 for more debate. +-} + +occCheckExpand :: [Var] -> Type -> Maybe Type +-- See Note [Occurs check expansion] +-- We may have needed to do some type synonym unfolding in order to +-- get rid of the variable (or forall), so we also return the unfolded +-- version of the type, which is guaranteed to be syntactically free +-- of the given type variable. If the type is already syntactically +-- free of the variable, then the same type is returned. +occCheckExpand vs_to_avoid ty + | null vs_to_avoid -- Efficient shortcut + = Just ty -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase + + | otherwise + = go (mkVarSet vs_to_avoid, emptyVarEnv) ty + where + go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type + -- The VarSet is the set of variables we are trying to avoid + -- The VarEnv carries mappings necessary + -- because of kind expansion + go (as, env) ty@(TyVarTy tv) + | Just tv' <- lookupVarEnv env tv = return (mkTyVarTy tv') + | bad_var_occ as tv = Nothing + | otherwise = return ty + + go _ ty@(LitTy {}) = return ty + go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (AppTy ty1' ty2') } + go cxt ty@(FunTy _ w ty1 ty2) + = do { w' <- go cxt w + ; ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) } + go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) + = do { ki' <- go cxt (varType tv) + ; let tv' = setVarType tv ki' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go (as', env') body_ty + ; return (ForAllTy (Bndr tv' vis) body') } + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go cxt ty@(TyConApp tc tys) + = case mapM (go cxt) tys of + Just tys' -> return (TyConApp tc tys') + Nothing | Just ty' <- coreView ty -> go cxt ty' + | otherwise -> Nothing + -- Failing that, try to expand a synonym + + go cxt (CastTy ty co) = do { ty' <- go cxt ty + ; co' <- go_co cxt co + ; return (CastTy ty' co') } + go cxt (CoercionTy co) = do { co' <- go_co cxt co + ; return (CoercionTy co') } + + ------------------ + bad_var_occ :: VarSet -> Var -> Bool + -- Works for TyVar and CoVar + -- See Note [Occurrence checking: look inside kinds] + bad_var_occ vs_to_avoid v + = v `elemVarSet` vs_to_avoid + || tyCoVarsOfType (varType v) `intersectsVarSet` vs_to_avoid + + ------------------ + go_mco _ MRefl = return MRefl + go_mco ctx (MCo co) = MCo <$> go_co ctx co + + ------------------ + go_co cxt (Refl ty) = do { ty' <- go cxt ty + ; return (Refl ty') } + go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco + ; ty' <- go cxt ty + ; return (GRefl r ty' mco') } + -- Note: Coercions do not contain type synonyms + go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args + ; return (TyConAppCo r tc args') } + go_co cxt (AppCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (AppCo co' arg') } + go_co cxt@(as, env) (ForAllCo tv kind_co body_co) + = do { kind_co' <- go_co cxt kind_co + ; let tv' = setVarType tv $ + coercionLKind kind_co' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go_co (as', env') body_co + ; return (ForAllCo tv' kind_co' body') } + go_co cxt co@(FunCo { fco_mult = w, fco_arg = co1 ,fco_res = co2 }) + = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; w' <- go_co cxt w + ; return (co { fco_mult = w', fco_arg = co1', fco_res = co2' })} + + go_co (as,env) co@(CoVarCo c) + | Just c' <- lookupVarEnv env c = return (CoVarCo c') + | bad_var_occ as c = Nothing + | otherwise = return co + + go_co (as,_) co@(HoleCo h) + | bad_var_occ as (ch_co_var h) = Nothing + | otherwise = return co + + go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args + ; return (AxiomInstCo ax ind args') } + go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p + ; ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (UnivCo p' r ty1' ty2') } + go_co cxt (SymCo co) = do { co' <- go_co cxt co + ; return (SymCo co') } + go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (TransCo co1' co2') } + go_co cxt (SelCo n co) = do { co' <- go_co cxt co + ; return (SelCo n co') } + go_co cxt (LRCo lr co) = do { co' <- go_co cxt co + ; return (LRCo lr co') } + go_co cxt (InstCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (InstCo co' arg') } + go_co cxt (KindCo co) = do { co' <- go_co cxt co + ; return (KindCo co') } + go_co cxt (SubCo co) = do { co' <- go_co cxt co + ; return (SubCo co') } + go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs + ; return (AxiomRuleCo ax cs') } + + ------------------ + go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co + go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co + go_prov _ p@(PluginProv _) = return p + go_prov _ p@(CorePrepProv _) = return p + diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index d78e90f0c9..ce97294a94 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -27,14 +27,14 @@ module GHC.Core.TyCo.Ppr import GHC.Prelude import {-# SOURCE #-} GHC.CoreToIface - ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr + ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) import {-# SOURCE #-} GHC.Core.DataCon ( dataConFullSig , dataConUserTyVarBinders, DataCon ) -import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern One, pattern Many, - splitForAllReqTVBinders, splitForAllInvisTVBinders ) +import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern OneTy, pattern ManyTy, + splitForAllReqTyBinders, splitForAllInvisTyBinders ) import GHC.Core.TyCon import GHC.Core.TyCo.Rep @@ -42,7 +42,7 @@ import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs import GHC.Core.Class import GHC.Types.Var - +import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) import GHC.Iface.Type import GHC.Types.Var.Set @@ -161,18 +161,18 @@ pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType pprSigmaType :: Type -> SDoc pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType -pprForAll :: [TyCoVarBinder] -> SDoc -pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) +pprForAll :: [ForAllTyBinder] -> SDoc +pprForAll tvs = pprIfaceForAll (toIfaceForAllBndrs tvs) -- | Print a user-level forall; see @Note [When to print foralls]@ in -- "GHC.Iface.Type". -pprUserForAll :: [TyCoVarBinder] -> SDoc -pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr +pprUserForAll :: [ForAllTyBinder] -> SDoc +pprUserForAll = pprUserIfaceForAll . toIfaceForAllBndrs -pprTCvBndrs :: [TyCoVarBinder] -> SDoc +pprTCvBndrs :: [ForAllTyBinder] -> SDoc pprTCvBndrs tvs = sep (map pprTCvBndr tvs) -pprTCvBndr :: TyCoVarBinder -> SDoc +pprTCvBndr :: ForAllTyBinder -> SDoc pprTCvBndr = pprTyVar . binderVar pprTyVars :: [TyVar] -> SDoc @@ -230,18 +230,15 @@ debug_ppr_ty _ (LitTy l) debug_ppr_ty _ (TyVarTy tv) = ppr tv -- With -dppr-debug we get (tv :: kind) -debug_ppr_ty prec ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) +debug_ppr_ty prec (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) = maybeParen prec funPrec $ sep [debug_ppr_ty funPrec arg, arr <+> debug_ppr_ty prec res] where - arr = case af of - VisArg -> case mult of - One -> lollipop - Many -> arrow - w -> mulArrow (const ppr) w - InvisArg -> case mult of - Many -> darrow - _ -> pprPanic "unexpected multiplicity" (ppr ty) + arr = pprArrowWithMultiplicity af $ + case mult of + OneTy -> Left True + ManyTy -> Left False + _ -> Right (debug_ppr_ty appPrec mult) debug_ppr_ty prec (TyConApp tc tys) | null tys = ppr tc @@ -263,7 +260,7 @@ debug_ppr_ty _ (CoercionTy co) -- Invisible forall: forall {k} (a :: k). t debug_ppr_ty prec t - | (bndrs, body) <- splitForAllInvisTVBinders t + | (bndrs, body) <- splitForAllInvisTyBinders t , not (null bndrs) = maybeParen prec funPrec $ sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <> dot, @@ -276,7 +273,7 @@ debug_ppr_ty prec t -- Visible forall: forall x y -> t debug_ppr_ty prec t - | (bndrs, body) <- splitForAllReqTVBinders t + | (bndrs, body) <- splitForAllReqTyBinders t , not (null bndrs) = maybeParen prec funPrec $ sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <+> arrow, @@ -288,7 +285,7 @@ debug_ppr_ty prec t -- Impossible case: neither visible nor invisible forall. debug_ppr_ty _ ForAllTy{} - = panic "debug_ppr_ty: neither splitForAllInvisTVBinders nor splitForAllReqTVBinders returned any binders" + = panic "debug_ppr_ty: neither splitForAllInvisTyBinders nor splitForAllReqTyBinders returned any binders" {- Note [Infix type variables] diff --git a/compiler/GHC/Core/TyCo/Ppr.hs-boot b/compiler/GHC/Core/TyCo/Ppr.hs-boot index 2b1a787f1f..c031db2f9a 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs-boot +++ b/compiler/GHC/Core/TyCo/Ppr.hs-boot @@ -5,6 +5,7 @@ import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit) import GHC.Utils.Outputable ( SDoc ) pprType :: Type -> SDoc +debugPprType :: Type -> SDoc pprKind :: Kind -> SDoc pprCo :: Coercion -> SDoc pprTyLit :: TyLit -> SDoc diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index f743dddc8b..9f1267ab56 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -30,13 +30,13 @@ module GHC.Core.TyCo.Rep ( TyLit(..), KindOrType, Kind, - RuntimeRepType, + RuntimeRepType, LevityType, KnotTied, PredType, ThetaType, FRRType, -- Synonyms - ArgFlag(..), AnonArgFlag(..), + ForAllTyFlag(..), FunTyFlag(..), -- * Coercions - Coercion(..), + Coercion(..), CoSel(..), FunSel(..), UnivCoProvenance(..), CoercionHole(..), coHoleCoVar, setCoHoleCoVar, CoercionN, CoercionR, CoercionP, KindCoercion, @@ -45,23 +45,15 @@ module GHC.Core.TyCo.Rep ( -- * Functions over types mkNakedTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, - mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, + mkFunTy, mkNakedKindFunTy, + mkVisFunTy, mkScaledFunTys, + mkInvisFunTy, mkInvisFunTys, + tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys, mkForAllTy, mkForAllTys, mkInvisForAllTys, mkPiTy, mkPiTys, - mkFunTyMany, - mkScaledFunTy, mkVisFunTyMany, mkVisFunTysMany, - mkInvisFunTyMany, mkInvisFunTysMany, nonDetCmpTyLit, cmpTyLit, - -- * Functions over binders - TyCoBinder(..), TyCoVarBinder, TyBinder, - binderVar, binderVars, binderType, binderArgFlag, - delBinderVar, - isInvisibleArgFlag, isVisibleArgFlag, - isInvisibleBinder, isVisibleBinder, - isTyBinder, isNamedBinder, - -- * Functions over coercions pickLR, @@ -78,27 +70,30 @@ module GHC.Core.TyCo.Rep ( import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) +import {-# SOURCE #-} GHC.Builtin.Types +import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstraint ) -- Transitively pulls in a LOT of stuff, better to break the loop -- friends: import GHC.Types.Var -import GHC.Types.Var.Set import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -- others -import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) +import GHC.Builtin.Names + import GHC.Types.Basic ( LeftOrRight(..), pickLR ) -import GHC.Types.Unique ( Uniquable(..) ) import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Binary -- libraries import qualified Data.Data as Data hiding ( TyCon ) import Data.IORef ( IORef ) -- for CoercionHole +import Control.DeepSeq {- ********************************************************************** * * @@ -116,6 +111,9 @@ type Kind = Type -- | Type synonym used for types of kind RuntimeRep. type RuntimeRepType = Type +-- | Type synonym used for types of kind Levity. +type LevityType = Type + -- A type with a syntactically fixed RuntimeRep, in the sense -- of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. type FRRType = Type @@ -155,7 +153,7 @@ data Type -- can appear as the right hand side of a type synonym. | ForAllTy - {-# UNPACK #-} !TyCoVarBinder + {-# UNPACK #-} !ForAllTyBinder Type -- ^ A Π type. -- Note [When we quantify over a coercion variable] -- INVARIANT: If the binder is a coercion variable, it must @@ -164,10 +162,14 @@ data Type | FunTy -- ^ FUN m t1 t2 Very common, so an important special case -- See Note [Function types] - { ft_af :: AnonArgFlag -- Is this (->) or (=>)? - , ft_mult :: Mult -- Multiplicity - , ft_arg :: Type -- Argument type - , ft_res :: Type } -- Result type + { ft_af :: FunTyFlag -- Is this (->/FUN) or (=>) or (==>)? + -- This info is fully specified by the kinds in + -- ft_arg and ft_res + -- Note [FunTyFlag] in GHC.Types.Var + + , ft_mult :: Mult -- Multiplicity; always Many for (=>) and (==>) + , ft_arg :: Type -- Argument type + , ft_res :: Type } -- Result type | LitTy TyLit -- ^ Type literals are similar to type constructors. @@ -232,9 +234,9 @@ FunTy is the constructor for a function type. Here are the details: TYPE r2 -> Type mkTyConApp ensures that we convert a saturated application - TyConApp FUN [m,r1,r2,t1,t2] into FunTy VisArg m t1 t2 + TyConApp FUN [m,r1,r2,t1,t2] into FunTy FTF_T_T m t1 t2 dropping the 'r1' and 'r2' arguments; they are easily recovered - from 't1' and 't2'. The visibility is always VisArg, because + from 't1' and 't2'. The FunTyFlag is always FTF_T_T, because we build constraint arrows (=>) with e.g. mkPhiTy and friends, never `mkTyConApp funTyCon args`. @@ -255,12 +257,8 @@ FunTy is the constructor for a function type. Here are the details: There is a plan to change the argument order and make the multiplicity argument nondependent in #20164. -* The ft_af field says whether or not this is an invisible argument - VisArg: t1 -> t2 Ordinary function type - InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, - i.e. t1 :: Constraint +* Re the ft_af field: see Note [FunTyFlag] in GHC.Types.Var See Note [Types for coercions, predicates, and evidence] - This visibility info makes no difference in Core; it matters only when we regard the type as a Haskell source type. @@ -299,8 +297,8 @@ When treated as a user type, of kind Constrain), are just regular old types, are visible, and are not implicitly instantiated. -In a FunTy { ft_af = InvisArg }, the argument type is always -a Predicate type. +In a FunTy { ft_af = af } and af = FTF_C_T or FTF_C_C, the argument +type is always a Predicate type. Note [Weird typing rule for ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -363,7 +361,7 @@ How does this work? the box on the spot. * How can we get such a MkT? By promoting a GADT-style data - constructor + constructor, written with an explicit equality constraint. data T a b where MkT :: (a~b) => a -> b -> T a b See DataCon.mkPromotedDataCon @@ -386,15 +384,15 @@ How does this work? * The existence of promoted MkT with an equality-constraint argument is the (only) reason that the AnonTCB constructor - of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). + of TyConBndrVis carries an FunTyFlag. For example, when we promote the data constructor MkT :: forall a b. (a~b) => a -> b -> T a b we get a PromotedDataCon with tyConBinders Bndr (a :: Type) (NamedTCB Inferred) Bndr (b :: Type) (NamedTCB Inferred) - Bndr (_ :: a ~ b) (AnonTCB InvisArg) - Bndr (_ :: a) (AnonTCB VisArg)) - Bndr (_ :: b) (AnonTCB VisArg)) + Bndr (_ :: a ~ b) (AnonTCB FTF_C_T) + Bndr (_ :: a) (AnonTCB FTF_T_T)) + Bndr (_ :: b) (AnonTCB FTF_T_T)) * One might reasonably wonder who *unpacks* these boxes once they are made. After all, there is no type-level `case` construct. The @@ -539,12 +537,6 @@ cannot appear outside a coercion. We do not (yet) have a function to extract relevant free variables, but it would not be hard to write if the need arises. -Besides eqType, another equality relation that upholds the (EQ) property above -is /typechecker equality/, which is implemented as -GHC.Tc.Utils.TcType.tcEqType. See -Note [Typechecker equality vs definitional equality] in GHC.Tc.Utils.TcType for -what the difference between eqType and tcEqType is. - Note [Respecting definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note [Non-trivial definitional equality] introduces the property (EQ). @@ -634,7 +626,7 @@ the kinds of the arg and the res. Note [When we quantify over a coercion variable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The TyCoVarBinder in a ForAllTy can be (most often) a TyVar or (rarely) +The ForAllTyBinder in a ForAllTy can be (most often) a TyVar or (rarely) a CoVar. We support quantifying over a CoVar here in order to support a homogeneous (~#) relation (someday -- not yet implemented). Here is the example: @@ -664,11 +656,11 @@ See #15710 about that. Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have - \(co:t1 ~ t2). e + \(co:t1 ~# t2). e -What type should we give to this expression? - (1) forall (co:t1 ~ t2) -> t - (2) (t1 ~ t2) -> t +What type should we give to the above expression? + (1) forall (co:t1 ~# t2) -> t + (2) (t1 ~# t2) -> t If co is used in t, (1) should be the right choice. if co is not used in t, we would like to have (1) and (2) equivalent. @@ -734,242 +726,6 @@ type KnotTied ty = ty {- ********************************************************************** * * - TyCoBinder and ArgFlag -* * -********************************************************************** -} - --- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be --- dependent ('Named') or nondependent ('Anon'). They may also be visible or --- not. See Note [TyCoBinders] -data TyCoBinder - = Named TyCoVarBinder -- A type-lambda binder - | Anon AnonArgFlag (Scaled Type) -- A term-lambda binder. Type here can be CoercionTy. - -- Visibility is determined by the AnonArgFlag - deriving Data.Data - -instance Outputable TyCoBinder where - ppr (Anon af ty) = ppr af <+> ppr ty - ppr (Named (Bndr v Required)) = ppr v - ppr (Named (Bndr v Specified)) = char '@' <> ppr v - ppr (Named (Bndr v Inferred)) = braces (ppr v) - - --- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' --- in the 'Named' field. -type TyBinder = TyCoBinder - --- | Remove the binder's variable from the set, if the binder has --- a variable. -delBinderVar :: VarSet -> TyCoVarBinder -> VarSet -delBinderVar vars (Bndr tv _) = vars `delVarSet` tv - --- | Does this binder bind an invisible argument? -isInvisibleBinder :: TyCoBinder -> Bool -isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis -isInvisibleBinder (Anon InvisArg _) = True -isInvisibleBinder (Anon VisArg _) = False - --- | Does this binder bind a visible argument? -isVisibleBinder :: TyCoBinder -> Bool -isVisibleBinder = not . isInvisibleBinder - -isNamedBinder :: TyCoBinder -> Bool -isNamedBinder (Named {}) = True -isNamedBinder (Anon {}) = False - --- | If its a named binder, is the binder a tyvar? --- Returns True for nondependent binder. --- This check that we're really returning a *Ty*Binder (as opposed to a --- coercion binder). That way, if/when we allow coercion quantification --- in more places, we'll know we missed updating some function. -isTyBinder :: TyCoBinder -> Bool -isTyBinder (Named bnd) = isTyVarBinder bnd -isTyBinder _ = True - -{- Note [TyCoBinders] -~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyCoVarBinder. But a type can be decomposed -to a telescope consisting of a [TyCoBinder] - -A TyCoBinder represents the type of binders -- that is, the type of an -argument to a Pi-type. GHC Core currently supports two different -Pi-types: - - * A non-dependent function type, - written with ->, e.g. ty1 -> ty2 - represented as FunTy ty1 ty2. These are - lifted to Coercions with the corresponding FunCo. - - * A dependent compile-time-only polytype, - written with forall, e.g. forall (a:*). ty - represented as ForAllTy (Bndr a v) ty - -Both Pi-types classify terms/types that take an argument. In other -words, if `x` is either a function or a polytype, `x arg` makes sense -(for an appropriate `arg`). - - -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. - Each TyCoVarBinder - Bndr a tvis - is equipped with tvis::ArgFlag, which says whether or not arguments - for this binder should be visible (explicit) in source Haskell. - -* A TyCon contains a list of TyConBinders. Each TyConBinder - Bndr a cvis - is equipped with cvis::TyConBndrVis, which says whether or not type - and kind arguments for this TyCon should be visible (explicit) in - source Haskell. - -This table summarises the visibility rules: ---------------------------------------------------------------------------------------- -| Occurrences look like this -| GHC displays type as in Haskell source code -|-------------------------------------------------------------------------------------- -| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term -| tvis :: ArgFlag -| tvis = Inferred: f :: forall {a}. type Arg not allowed: f - f :: forall {co}. type Arg not allowed: f -| tvis = Specified: f :: forall a. type Arg optional: f or f @Int -| tvis = Required: T :: forall k -> type Arg required: T * -| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] -| -| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon -| cvis :: TyConBndrVis -| cvis = AnonTCB: T :: kind -> kind Required: T * -| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T -| T :: forall {co}. kind Arg not allowed: T -| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T -| cvis = NamedTCB Required: T :: forall k -> kind Required: T * ---------------------------------------------------------------------------------------- - -[1] In types, in the Specified case, it would make sense to allow - optional kind applications, thus (T @*), but we have not - yet implemented that - ----- In term declarations ---- - -* Inferred. Function defn, with no signature: f1 x = x - We infer f1 :: forall {a}. a -> a, with 'a' Inferred - It's Inferred because it doesn't appear in any - user-written signature for f1 - -* Specified. Function defn, with signature (implicit forall): - f2 :: a -> a; f2 x = x - So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified - even though 'a' is not bound in the source code by an explicit forall - -* Specified. Function defn, with signature (explicit forall): - f3 :: forall a. a -> a; f3 x = x - So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified - -* Inferred. Function defn, with signature (explicit forall), marked as inferred: - f4 :: forall {a}. a -> a; f4 x = x - So f4 gets the type f4 :: forall {a}. a -> a, with 'a' Inferred - It's Inferred because the user marked it as such, even though it does appear - in the user-written signature for f4 - -* Inferred/Specified. Function signature with inferred kind polymorphism. - f5 :: a b -> Int - So 'f5' gets the type f5 :: forall {k} (a:k->*) (b:k). a b -> Int - Here 'k' is Inferred (it's not mentioned in the type), - but 'a' and 'b' are Specified. - -* Specified. Function signature with explicit kind polymorphism - f6 :: a (b :: k) -> Int - This time 'k' is Specified, because it is mentioned explicitly, - so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int - -* Similarly pattern synonyms: - Inferred - from inferred types (e.g. no pattern type signature) - - or from inferred kind polymorphism - ----- In type declarations ---- - -* Inferred (k) - data T1 a b = MkT1 (a b) - Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * - The kind variable 'k' is Inferred, since it is not mentioned - - Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, - and Anon binders don't have a visibility flag. (Or you could think - of Anon having an implicit Required flag.) - -* Specified (k) - data T2 (a::k->*) b = MkT (a b) - Here T's kind is T :: forall (k:*). (k->*) -> k -> * - The kind variable 'k' is Specified, since it is mentioned in - the signature. - -* Required (k) - data T k (a::k->*) b = MkT (a b) - Here T's kind is T :: forall k:* -> (k->*) -> k -> * - The kind is Required, since it bound in a positional way in T's declaration - Every use of T must be explicitly applied to a kind - -* Inferred (k1), Specified (k) - data T a b (c :: k) = MkT (a b) (Proxy c) - Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * - So 'k' is Specified, because it appears explicitly, - but 'k1' is Inferred, because it does not - -Generally, in the list of TyConBinders for a TyCon, - -* Inferred arguments always come first -* Specified, Anon and Required can be mixed - -e.g. - data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... - -Here Foo's TyConBinders are - [Required 'a', Specified 'b', Anon] -and its kind prints as - Foo :: forall a -> forall b. (a -> b -> Type) -> Type - -See also Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl - ----- Printing ----- - - We print forall types with enough syntax to tell you their visibility - flag. But this is not source Haskell, and these types may not all - be parsable. - - Specified: a list of Specified binders is written between `forall` and `.`: - const :: forall a b. a -> b -> a - - Inferred: like Specified, but every binder is written in braces: - f :: forall {k} (a:k). S k a -> Int - - Required: binders are put between `forall` and `->`: - T :: forall k -> * - ----- Other points ----- - -* In classic Haskell, all named binders (that is, the type variables in - a polymorphic function type f :: forall a. a -> a) have been Inferred. - -* Inferred variables correspond to "generalized" variables from the - Visible Type Applications paper (ESOP'16). - -Note [No Required TyCoBinder in terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Required foralls for term variables, including pattern -synonyms and data constructors. Why? Because then an application -would need a /compulsory/ type argument (possibly without an "@"?), -thus (f Int); and we don't have concrete syntax for that. - -We could change this decision, but Required, Named TyCoBinders are rare -anyway. (Most are Anons.) - -However the type of a term can (just about) have a required quantifier; -see Note [Required quantifiers in the type of a term] in GHC.Tc.Gen.Expr. --} - - -{- ********************************************************************** -* * PredType * * ********************************************************************** -} @@ -1041,60 +797,106 @@ mkTyCoVarTy v mkTyCoVarTys :: [TyCoVar] -> [Type] mkTyCoVarTys = map mkTyCoVarTy -infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy`, `mkVisFunTyMany`, - `mkInvisFunTyMany` -- Associates to the right - -mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type -mkFunTy af mult arg res = FunTy { ft_af = af - , ft_mult = mult - , ft_arg = arg - , ft_res = res } - -mkScaledFunTy :: AnonArgFlag -> Scaled Type -> Type -> Type -mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res - -mkVisFunTy, mkInvisFunTy :: Mult -> Type -> Type -> Type -mkVisFunTy = mkFunTy VisArg -mkInvisFunTy = mkFunTy InvisArg - -mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type -mkFunTyMany af = mkFunTy af manyDataConTy +infixr 3 `mkFunTy`, `mkInvisFunTy`, `mkVisFunTyMany` + +mkNakedKindFunTy :: FunTyFlag -> Kind -> Kind -> Kind +-- See Note [Naked FunTy] in GHC.Builtin.Types +-- Always Many multiplicity; kinds have no linearity +mkNakedKindFunTy af arg res + = FunTy { ft_af = af, ft_mult = manyDataConTy + , ft_arg = arg, ft_res = res } + +mkFunTy :: HasDebugCallStack => FunTyFlag -> Mult -> Type -> Type -> Type +mkFunTy af mult arg res + = assertPpr (af == chooseFunTyFlag arg res) (vcat + [ text "af" <+> ppr af + , text "chooseAAF" <+> ppr (chooseFunTyFlag arg res) + , text "arg" <+> ppr arg <+> dcolon <+> ppr (typeKind arg) + , text "res" <+> ppr res <+> dcolon <+> ppr (typeKind res) ]) $ + FunTy { ft_af = af + , ft_mult = mult + , ft_arg = arg + , ft_res = res } + +mkInvisFunTy :: HasDebugCallStack => Type -> Type -> Type +mkInvisFunTy arg res + = mkFunTy (invisArg (typeTypeOrConstraint res)) manyDataConTy arg res + +mkInvisFunTys :: HasDebugCallStack => [Type] -> Type -> Type +mkInvisFunTys args res + = foldr (mkFunTy af manyDataConTy) res args + where + af = invisArg (typeTypeOrConstraint res) + +tcMkVisFunTy :: Mult -> Type -> Type -> Type +-- Always TypeLike, user-specified multiplicity. +-- Does not have the assert-checking in mkFunTy: used by the typechecker +-- to avoid looking at the result kind, which may not be zonked +tcMkVisFunTy mult arg res + = FunTy { ft_af = visArgTypeLike, ft_mult = mult + , ft_arg = arg, ft_res = res } + +tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type +-- Always TypeLike, invisible argument +-- Does not have the assert-checking in mkFunTy: used by the typechecker +-- to avoid looking at the result kind, which may not be zonked +tcMkInvisFunTy res_torc arg res + = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy + , ft_arg = arg, ft_res = res } + +mkVisFunTy :: HasDebugCallStack => Mult -> Type -> Type -> Type +-- Always TypeLike, user-specified multiplicity. +mkVisFunTy = mkFunTy visArgTypeLike +-- | Make nested arrow types -- | Special, common, case: Arrow type with mult Many -mkVisFunTyMany :: Type -> Type -> Type +mkVisFunTyMany :: HasDebugCallStack => Type -> Type -> Type +-- Always TypeLike, multiplicity Many mkVisFunTyMany = mkVisFunTy manyDataConTy -mkInvisFunTyMany :: Type -> Type -> Type -mkInvisFunTyMany = mkInvisFunTy manyDataConTy - --- | Make nested arrow types -mkVisFunTys :: [Scaled Type] -> Type -> Type -mkVisFunTys tys ty = foldr (mkScaledFunTy VisArg) ty tys - mkVisFunTysMany :: [Type] -> Type -> Type +-- Always TypeLike, multiplicity Many mkVisFunTysMany tys ty = foldr mkVisFunTyMany ty tys -mkInvisFunTysMany :: [Type] -> Type -> Type -mkInvisFunTysMany tys ty = foldr mkInvisFunTyMany ty tys +--------------- +mkScaledFunTy :: HasDebugCallStack => FunTyFlag -> Scaled Type -> Type -> Type +mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res + +mkScaledFunTys :: HasDebugCallStack => [Scaled Type] -> Type -> Type +-- All visible args +-- Result type can be TypeLike or ConstraintLike +-- Example of the latter: dataConWrapperType for the data con of a class +mkScaledFunTys tys ty = foldr (mkScaledFunTy af) ty tys + where + af = visArg (typeTypeOrConstraint ty) + +tcMkScaledFunTys :: [Scaled Type] -> Type -> Type +-- All visible args +-- Result type must be TypeLike +-- No mkFunTy assert checking; result kind may not be zonked +tcMkScaledFunTys tys ty = foldr mk ty tys + where + mk (Scaled mult arg) res = tcMkVisFunTy mult arg res +--------------- -- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder -- See Note [Unused coercion variable in ForAllTy] -mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type -mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty +mkForAllTy :: ForAllTyBinder -> Type -> Type +mkForAllTy = ForAllTy -- | Wraps foralls over the type using the provided 'TyCoVar's from left to right -mkForAllTys :: [TyCoVarBinder] -> Type -> Type +mkForAllTys :: [ForAllTyBinder] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars) -mkPiTy :: TyCoBinder -> Type -> Type -mkPiTy (Anon af ty1) ty2 = mkScaledFunTy af ty1 ty2 -mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty +mkPiTy :: PiTyBinder -> Type -> Type +mkPiTy (Anon ty1 af) ty2 = mkScaledFunTy af ty1 ty2 +mkPiTy (Named bndr) ty = mkForAllTy bndr ty -mkPiTys :: [TyCoBinder] -> Type -> Type +mkPiTys :: [PiTyBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs -- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you @@ -1158,13 +960,15 @@ data Coercion | ForAllCo TyCoVar KindCoercion Coercion -- ForAllCo :: _ -> N -> e -> e - | FunCo Role CoercionN Coercion Coercion -- lift FunTy - -- FunCo :: "e" -> N -> e -> e -> e - -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? - -- Because the AnonArgFlag has no impact on Core; it is only - -- there to guide implicit instantiation of Haskell source - -- types, and that is irrelevant for coercions, which are - -- Core-only. + | FunCo -- FunCo :: "e" -> N/P -> e -> e -> e + -- See Note [FunCo] for fco_afl, fco_afr + { fco_role :: Role + , fco_afl :: FunTyFlag -- Arrow for coercionLKind + , fco_afr :: FunTyFlag -- Arrow for coercionRKind + , fco_mult :: CoercionN + , fco_arg, fco_res :: Coercion } + -- (if the role "e" is Phantom, the first coercion is, too) + -- the first coercion is for the multiplicity -- These are special | CoVarCo CoVar -- :: _ -> (N or R) @@ -1191,14 +995,7 @@ data Coercion | SymCo Coercion -- :: e -> e | TransCo Coercion Coercion -- :: e -> e -> e - | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) - -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) - -- Using NthCo on a ForAllCo gives an N coercion always - -- See Note [NthCo and newtypes] - -- - -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) - -- That is: the role of the entire coercion is redundantly cached here. - -- See Note [NthCo Cached Roles] + | SelCo CoSel Coercion -- See Note [SelCo] | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) -- :: _ -> N -> N @@ -1218,6 +1015,27 @@ data Coercion -- Only present during typechecking deriving Data.Data +data CoSel -- See Note [SelCo] + = SelTyCon Int Role -- Decomposes (T co1 ... con); zero-indexed + -- Invariant: Given: SelCo (SelTyCon i r) co + -- we have r == tyConRole (coercionRole co) tc + -- and tc1 == tc2 + -- where T tc1 _ = coercionLKind co + -- T tc2 _ = coercionRKind co + -- See Note [SelCo] + + | SelFun FunSel -- Decomposes (co1 -> co2) + + | SelForAll -- Decomposes (forall a. co) + + deriving( Eq, Data.Data ) + +data FunSel -- See Note [SelCo] + = SelMult -- Multiplicity + | SelArg -- Argument of function + | SelRes -- Result of function + deriving( Eq, Data.Data ) + type CoercionN = Coercion -- always nominal type CoercionR = Coercion -- always representational type CoercionP = Coercion -- always phantom @@ -1226,6 +1044,36 @@ type KindCoercion = CoercionN -- always nominal instance Outputable Coercion where ppr = pprCo +instance Outputable CoSel where + ppr (SelTyCon n _r) = text "Tc" <> parens (int n) + ppr SelForAll = text "All" + ppr (SelFun fs) = text "Fun" <> parens (ppr fs) + +instance Outputable FunSel where + ppr SelMult = text "mult" + ppr SelArg = text "arg" + ppr SelRes = text "res" + +instance Binary CoSel where + put_ bh (SelTyCon n r) = do { putByte bh 0; put_ bh n; put_ bh r } + put_ bh SelForAll = putByte bh 1 + put_ bh (SelFun SelMult) = putByte bh 2 + put_ bh (SelFun SelArg) = putByte bh 3 + put_ bh (SelFun SelRes) = putByte bh 4 + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { n <- get bh; r <- get bh; return (SelTyCon n r) } + 1 -> return SelForAll + 2 -> return (SelFun SelMult) + 3 -> return (SelFun SelArg) + _ -> return (SelFun SelRes) } + +instance NFData CoSel where + rnf (SelTyCon n r) = n `seq` r `seq` () + rnf SelForAll = () + rnf (SelFun fs) = fs `seq` () + -- | A semantically more meaningful type to represent what may or may not be a -- useful 'Coercion'. data MCoercion @@ -1246,7 +1094,7 @@ instance Outputable MCoercion where Invariant 1: Refl lifting Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. For example - (Refl T) (Refl a) (Refl b) is normalised (by mkAPpCo) to (Refl (T a b)). + (Refl T) (Refl a) (Refl b) is normalised (by mkAppCo) to (Refl (T a b)). You might think that a consequences is: Every identity coercion has Refl at the root @@ -1298,6 +1146,72 @@ It is easy to see that A nominal reflexive coercion is quite common, so we keep the special form Refl to save allocation. +Note [SelCo] +~~~~~~~~~~~~ +The Coercion form SelCo allows us to decompose a structural coercion, one +between ForallTys, or TyConApps, or FunTys. + +There are three forms, split by the CoSel field inside the SelCo: +SelTyCon, SelForAll, and SelFun. + +* SelTyCon: + + co : (T s1..sn) ~r0 (T t1..tn) + T is a data type, not a newtype, nor an arrow type + r = tyConRole tc r0 i + i < n (i is zero-indexed) + ---------------------------------- + SelCo (SelTyCon i r) : si ~r ti + + "Not a newtype": see Note [SelCo and newtypes] + "Not an arrow type": see SelFun below + + See Note [SelCo Cached Roles] + +* SelForAll: + co : forall (a:k1).t1 ~r0 forall (a:k2).t2 + ---------------------------------- + SelCo SelForAll : k1 ~N k2 + + NB: SelForAll always gives a Nominal coercion. + +* The SelFun form, for functions, has three sub-forms for the three + components of the function type (multiplicity, argument, result). + + co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) + r = funRole r0 SelMult + ---------------------------------- + SelCo (SelFun SelMult) : m1 ~r m2 + + co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) + r = funRole r0 SelArg + ---------------------------------- + SelCo (SelFun SelArg) : s1 ~r s2 + + co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) + r = funRole r0 SelRes + ---------------------------------- + SelCo (SelFun SelRes) : t1 ~r t2 + +Note [FunCo] +~~~~~~~~~~~~ +Just as FunTy has a ft_af :: FunTyFlag field, FunCo (which connects +two function types) has two FunTyFlag fields: + funco_afl, funco_afr :: FunTyFlag +In all cases, the FunTyFlag is recoverable from the kinds of the argument +and result types/coercions; but experiments show that it's better to +cache it. + +Why does FunCo need /two/ flags? If we have a single method class, +implemented as a newtype + class C a where { op :: [a] -> a } +then we can have a coercion + co :: C Int ~R ([Int]->Int) +So now we can define + FunCo co <Bool> : (C Int => Bool) ~R (([Int]->Int) -> Bool) +Notice that the left and right arrows are different! Hence two flags, +one for coercionLKind and one for coercionRKind. + Note [Coercion axioms applied to coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The reason coercion axioms can be applied to coercions and not just @@ -1416,7 +1330,7 @@ their representation type (see Type.coreView and Type.predTypeRep). This collapse is done by mkPredCo; there is no PredCo constructor in Coercion. This is important because we need Nth to work on predicates too: - Nth 1 ((~) [c] g) = g + SelCo (SelTyCon 1) ((~) [c] g) = g See Simplify.simplCoercionF, which generates such selections. Note [Roles] @@ -1530,7 +1444,7 @@ TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool The rules here dictate the roles of the parameters to mkTyConAppCo (should be checked by Lint). -Note [NthCo and newtypes] +Note [SelCo and newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -1547,20 +1461,21 @@ We can then build co = NTCo:N a ; sym (NTCo:N b) for any `a` and `b`. Because of the role annotation on N, if we use -NthCo, we'll get out a representational coercion. That is: +SelCo, we'll get out a representational coercion. That is: - NthCo r 0 co :: forall a b. a ~R b + SelCo (SelTyCon 0 r) co :: forall a b. a ~r b Yikes! Clearly, this is terrible. The solution is simple: forbid -NthCo to be used on newtypes if the internal coercion is representational. +SelCo to be used on newtypes if the internal coercion is representational. +See the SelCo equation for GHC.Core.Lint.lintCoercion. This is not just some corner case discovered by a segfault somewhere; it was discovered in the proof of soundness of roles and described in the "Safe Coercions" paper (ICFP '14). -Note [NthCo Cached Roles] +Note [SelCo Cached Roles] ~~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we cache the role of NthCo in the NthCo constructor? +Why do we cache the role of SelCo in the SelCo constructor? Because computing role(Nth i co) involves figuring out that co :: T tys1 ~ T tys2 @@ -1570,7 +1485,7 @@ at the tyConRoles of T. Avoiding bad asymptotic behaviour here means we have to compute the kind and role of a coercion simultaneously, which makes the code complicated and inefficient. -This only happens for NthCo. Caching the role solves the problem, and +This only happens for SelCo. Caching the role solves the problem, and allows coercionKind and coercionRole to be simple. See #11735 @@ -1886,7 +1801,7 @@ data TyCoFolder env a -- ^ What to do with coercion holes. -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". - , tcf_tycobinder :: env -> TyCoVar -> ArgFlag -> env + , tcf_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> env -- ^ The returned env is used in the extended scope } @@ -1921,27 +1836,28 @@ foldTyCo (TyCoFolder { tcf_view = view go_cos _ [] = mempty go_cos env (c:cs) = go_co env c `mappend` go_cos env cs - go_co env (Refl ty) = go_ty env ty - go_co env (GRefl _ ty MRefl) = go_ty env ty - go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co - go_co env (TyConAppCo _ _ args) = go_cos env args - go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 - go_co env (FunCo _ cw c1 c2) = go_co env cw `mappend` - go_co env c1 `mappend` - go_co env c2 - go_co env (CoVarCo cv) = covar env cv - go_co env (AxiomInstCo _ _ args) = go_cos env args - go_co env (HoleCo hole) = cohole env hole - go_co env (UnivCo p _ t1 t2) = go_prov env p `mappend` go_ty env t1 - `mappend` go_ty env t2 - go_co env (SymCo co) = go_co env co - go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2 - go_co env (AxiomRuleCo _ cos) = go_cos env cos - go_co env (NthCo _ _ co) = go_co env co - go_co env (LRCo _ co) = go_co env co - go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg - go_co env (KindCo co) = go_co env co - go_co env (SubCo co) = go_co env co + go_co env (Refl ty) = go_ty env ty + go_co env (GRefl _ ty MRefl) = go_ty env ty + go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co + go_co env (TyConAppCo _ _ args) = go_cos env args + go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (CoVarCo cv) = covar env cv + go_co env (AxiomInstCo _ _ args) = go_cos env args + go_co env (HoleCo hole) = cohole env hole + go_co env (UnivCo p _ t1 t2) = go_prov env p `mappend` go_ty env t1 + `mappend` go_ty env t2 + go_co env (SymCo co) = go_co env co + go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (AxiomRuleCo _ cos) = go_cos env cos + go_co env (SelCo _ co) = go_co env co + go_co env (LRCo _ co) = go_co env co + go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg + go_co env (KindCo co) = go_co env co + go_co env (SubCo co) = go_co env co + + go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 }) + = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2 + go_co env (ForAllCo tv kind_co co) = go_co env kind_co `mappend` go_ty env (varType tv) `mappend` go_co env' co @@ -1991,17 +1907,17 @@ coercionSize (Refl ty) = typeSize ty coercionSize (GRefl _ ty MRefl) = typeSize ty coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) -coercionSize (AppCo co arg) = coercionSize co + coercionSize arg -coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h -coercionSize (FunCo _ w co1 co2) = 1 + coercionSize co1 + coercionSize co2 - + coercionSize w +coercionSize (AppCo co arg) = coercionSize co + coercionSize arg +coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h +coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2 + + coercionSize w coercionSize (CoVarCo _) = 1 coercionSize (HoleCo _) = 1 coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 coercionSize (SymCo co) = 1 + coercionSize co coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (NthCo _ _ co) = 1 + coercionSize co +coercionSize (SelCo _ co) = 1 + coercionSize co coercionSize (LRCo _ co) = 1 + coercionSize co coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg coercionSize (KindCo co) = 1 + coercionSize co diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot index ffbbf64a1e..c2dd2a63fe 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs-boot +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -3,17 +3,19 @@ module GHC.Core.TyCo.Rep where import GHC.Utils.Outputable ( Outputable ) import Data.Data ( Data ) -import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag ) +import {-# SOURCE #-} GHC.Types.Var( Var, VarBndr, ForAllTyFlag, FunTyFlag ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) data Type data Coercion +data CoSel data UnivCoProvenance data TyLit -data TyCoBinder data MCoercion data Scaled a +scaledThing :: Scaled a -> a + type Mult = Type type PredType = Type @@ -23,9 +25,17 @@ type ThetaType = [PredType] type CoercionN = Coercion type MCoercionN = MCoercion -mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type -mkForAllTy :: Var -> ArgFlag -> Type -> Type -mkNakedTyConTy :: TyCon -> Type +mkForAllTy :: VarBndr Var ForAllTyFlag -> Type -> Type +mkNakedTyConTy :: TyCon -> Type +mkNakedKindFunTy :: FunTyFlag -> Type -> Type -> Type + + +-- To support Data instances in GHC.Core.Coercion.Axiom +instance Data Type + +-- To support instances PiTyBinder in Var +instance Data a => Data (Scaled a) -instance Data Type -- To support Data instances in GHC.Core.Coercion.Axiom +-- To support debug pretty-printing instance Outputable Type +instance Outputable a => Outputable (Scaled a) diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 18babd08dc..115dd3531f 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -44,9 +44,9 @@ module GHC.Core.TyCo.Subst substVarBndr, substVarBndrs, substTyVarBndr, substTyVarBndrs, substCoVarBndr, - substTyVar, substTyVars, substTyCoVars, - substTyCoBndr, - substForAllCoBndr, + substTyVar, substTyVars, substTyVarToTyVar, + substTyCoVars, + substTyCoBndr, substForAllCoBndr, substVarBndrUsing, substForAllCoBndrUsing, checkValidSubst, isValidTCvSubst, ) where @@ -54,11 +54,11 @@ module GHC.Core.TyCo.Subst import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type - ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp ) + ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp, getTyVar_maybe ) import {-# SOURCE #-} GHC.Core.Coercion - ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo + ( mkCoVarCo, mkKindCo, mkSelCo, mkTransCo , mkNomReflCo, mkSubCo, mkSymCo - , mkFunCo, mkForAllCo, mkUnivCo + , mkFunCo2, mkForAllCo, mkUnivCo , mkAxiomInstCo, mkAppCo, mkGReflCo , mkInstCo, mkLRCo, mkTyConAppCo , mkCoercionType @@ -375,7 +375,7 @@ extendTvSubst (Subst in_scope ids tvs cvs) tv ty = assert (isTyVar tv) $ Subst in_scope ids (extendVarEnv tvs tv ty) cvs -extendTvSubstBinderAndInScope :: Subst -> TyCoBinder -> Type -> Subst +extendTvSubstBinderAndInScope :: Subst -> PiTyBinder -> Type -> Subst extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty = assert (isTyVar v ) extendTvSubstAndInScope subst v ty @@ -820,6 +820,16 @@ substTyVar (Subst _ _ tenv _) tv Just ty -> ty Nothing -> TyVarTy tv +substTyVarToTyVar :: HasDebugCallStack => Subst -> TyVar -> TyVar +-- Apply the substitution, expecing the result to be a TyVarTy +substTyVarToTyVar (Subst _ _ tenv _) tv + = assert (isTyVar tv) $ + case lookupVarEnv tenv tv of + Just ty -> case getTyVar_maybe ty of + Just tv -> tv + Nothing -> pprPanic "substTyVarToTyVar" (ppr tv $$ ppr ty) + Nothing -> tv + substTyVars :: Subst -> [TyVar] -> [Type] substTyVars subst = map $ substTyVar subst @@ -884,14 +894,14 @@ subst_co subst co = case substForAllCoBndrUnchecked subst tv kind_co of (subst', tv', kind_co') -> ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co - go (FunCo r w co1 co2) = ((mkFunCo r $! go w) $! go co1) $! go co2 + go (FunCo r afl afr w co1 co2) = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2 go (CoVarCo cv) = substCoVar subst cv go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! (go_ty t1)) $! (go_ty t2) go (SymCo co) = mkSymCo $! (go co) go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) - go (NthCo r d co) = mkNthCo r d $! (go co) + go (SelCo d co) = mkSelCo d $! (go co) go (LRCo lr co) = mkLRCo lr $! (go co) go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg go (KindCo co) = mkKindCo $! (go co) @@ -1114,8 +1124,8 @@ cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) (subst' , tv ) = cloneTyVarBndr subst t uniq (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' -substTyCoBndr :: Subst -> TyCoBinder -> (Subst, TyCoBinder) -substTyCoBndr subst (Anon af ty) = (subst, Anon af (substScaledTy subst ty)) +substTyCoBndr :: Subst -> PiTyBinder -> (Subst, PiTyBinder) +substTyCoBndr subst (Anon ty af) = (subst, Anon (substScaledTy subst ty) af) substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis)) where (subst', tv') = substVarBndr subst tv diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs index 2cbebbd411..a1f6489374 100644 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -13,7 +13,7 @@ module GHC.Core.TyCo.Tidy tidyTyCoVarOcc, tidyTopType, tidyCo, tidyCos, - tidyTyCoVarBinder, tidyTyCoVarBinders + tidyForAllTyBinder, tidyForAllTyBinders ) where import GHC.Prelude @@ -78,17 +78,17 @@ getHelpfulOccName tv name = varName tv occ = getOccName name -tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis +tidyForAllTyBinder :: TidyEnv -> VarBndr TyCoVar vis -> (TidyEnv, VarBndr TyCoVar vis) -tidyTyCoVarBinder tidy_env (Bndr tv vis) +tidyForAllTyBinder tidy_env (Bndr tv vis) = (tidy_env', Bndr tv' vis) where (tidy_env', tv') = tidyVarBndr tidy_env tv -tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] +tidyForAllTyBinders :: TidyEnv -> [VarBndr TyCoVar vis] -> (TidyEnv, [VarBndr TyCoVar vis]) -tidyTyCoVarBinders tidy_env tvbs - = mapAccumL tidyTyCoVarBinder +tidyForAllTyBinders tidy_env tvbs + = mapAccumL tidyForAllTyBinder (avoidNameClashes (binderVars tvbs) tidy_env) tvbs --------------- @@ -175,14 +175,14 @@ tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) -- The following two functions differ from mkForAllTys and splitForAllTyCoVars in that --- they expect/preserve the ArgFlag argument. These belong to "GHC.Core.Type", but +-- they expect/preserve the ForAllTyFlag argument. These belong to "GHC.Core.Type", but -- how should they be named? -mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type +mkForAllTys' :: [(TyCoVar, ForAllTyFlag)] -> Type -> Type mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs where strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty -splitForAllTyCoVars' :: Type -> ([TyCoVar], [ArgFlag], Type) +splitForAllTyCoVars' :: Type -> ([TyCoVar], [ForAllTyFlag], Type) splitForAllTyCoVars' ty = go ty [] [] where go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) @@ -233,7 +233,7 @@ tidyCo env@(_, subst) co where (envp, tvp) = tidyVarBndr env tv -- the case above duplicates a bit of work in tidying h and the kind -- of tv. But the alternative is to use coercionKind, which seems worse. - go (FunCo r w co1 co2) = ((FunCo r $! go w) $! go co1) $! go co2 + go (FunCo r afl afr w co1 co2) = ((FunCo r afl afr $! go w) $! go co1) $! go co2 go (CoVarCo cv) = case lookupVarEnv subst cv of Nothing -> CoVarCo cv Just cv' -> CoVarCo cv' @@ -243,7 +243,7 @@ tidyCo env@(_, subst) co tidyType env t1) $! tidyType env t2 go (SymCo co) = SymCo $! go co go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 - go (NthCo r d co) = NthCo r d $! go co + go (SelCo d co) = SelCo d $! go co go (LRCo lr co) = LRCo lr $! go co go (InstCo co ty) = (InstCo $! go co) $! go ty go (KindCo co) = KindCo $! go co diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 9ecf34c6a5..2088de341f 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -17,14 +17,14 @@ module GHC.Core.TyCon( AlgTyConRhs(..), visibleDataCons, AlgTyConFlav(..), isNoParent, FamTyConFlav(..), Role(..), Injectivity(..), - RuntimeRepInfo(..), TyConFlavour(..), + PromDataConInfo(..), TyConFlavour(..), -- * TyConBinder - TyConBinder, TyConBndrVis(..), TyConTyCoBinder, + TyConBinder, TyConBndrVis(..), TyConPiTyBinder, mkNamedTyConBinder, mkNamedTyConBinders, mkRequiredTyConBinder, - mkAnonTyConBinder, mkAnonTyConBinders, - tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, + mkAnonTyConBinder, mkAnonTyConBinders, mkInvisAnonTyConBinder, + tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder, isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis, -- ** Field labels @@ -33,7 +33,6 @@ module GHC.Core.TyCon( -- ** Constructing TyCons mkAlgTyCon, mkClassTyCon, - mkFunTyCon, mkPrimTyCon, mkTupleTyCon, mkSumTyCon, @@ -46,15 +45,14 @@ module GHC.Core.TyCon( noTcTyConScopedTyVars, -- ** Predicates on TyCons - isAlgTyCon, isVanillaAlgTyCon, isConstraintKindCon, + isAlgTyCon, isVanillaAlgTyCon, isClassTyCon, isFamInstTyCon, - isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isUnboxedSumTyCon, isPromotedTupleTyCon, isLiftedAlgTyCon, isTypeSynonymTyCon, - mustBeSaturated, + tyConMustBeSaturated, isPromotedDataCon, isPromotedDataCon_maybe, isDataKindsPromotedDataCon, isKindTyCon, isLiftedTypeKindTyConName, @@ -91,7 +89,7 @@ module GHC.Core.TyCon( tyConFamilySize, tyConStupidTheta, tyConArity, - tyConNullaryTy, + tyConNullaryTy, mkTyConTy, tyConRoles, tyConFlavour, tyConTuple_maybe, tyConClass_maybe, tyConATs, @@ -104,7 +102,7 @@ module GHC.Core.TyCon( unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, newTyConDataCon_maybe, algTcFields, - tyConRuntimeRepInfo, + tyConPromDataConInfo, tyConBinders, tyConResKind, tyConInvisTVBinders, tcTyConScopedTyVars, tcTyConIsPoly, mkTyConTagMap, @@ -139,13 +137,13 @@ import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.Core.TyCo.Rep - ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkNakedTyConTy ) + ( Kind, Type, PredType, mkForAllTy, mkNakedKindFunTy, mkNakedTyConTy ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) import {-# SOURCE #-} GHC.Builtin.Types ( runtimeRepTyCon, constraintKind, levityTyCon , multiplicityTyCon - , vecCountTyCon, vecElemTyCon, liftedTypeKind ) + , vecCountTyCon, vecElemTyCon ) import {-# SOURCE #-} GHC.Core.DataCon ( DataCon, dataConFieldLabels , dataConTyCon, dataConFullSig @@ -442,37 +440,44 @@ See #19367. ************************************************************************ * * - TyConBinder, TyConTyCoBinder + TyConBinder, TyConPiTyBinder * * ************************************************************************ -} type TyConBinder = VarBndr TyVar TyConBndrVis -type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis - -- Only PromotedDataCon has TyConTyCoBinders +type TyConPiTyBinder = VarBndr TyCoVar TyConBndrVis + -- Only PromotedDataCon has TyConPiTyBinders -- See Note [Promoted GADT data constructors] data TyConBndrVis - = NamedTCB ArgFlag - | AnonTCB AnonArgFlag + = NamedTCB ForAllTyFlag + | AnonTCB FunTyFlag instance Outputable TyConBndrVis where - ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag - ppr (AnonTCB af) = text "AnonTCB" <> ppr af + ppr (NamedTCB flag) = ppr flag + ppr (AnonTCB af) = ppr af -mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder -mkAnonTyConBinder af tv = assert (isTyVar tv) $ - Bndr tv (AnonTCB af) +mkAnonTyConBinder :: TyVar -> TyConBinder +-- Make a visible anonymous TyCon binder +mkAnonTyConBinder tv = assert (isTyVar tv) $ + Bndr tv (AnonTCB visArgTypeLike) -mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] -mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs +mkAnonTyConBinders :: [TyVar] -> [TyConBinder] +mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs -mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder +mkInvisAnonTyConBinder :: TyVar -> TyConBinder +-- Make an /invisible/ anonymous TyCon binder +-- Not used much +mkInvisAnonTyConBinder tv = assert (isTyVar tv) $ + Bndr tv (AnonTCB invisArgTypeLike) + +mkNamedTyConBinder :: ForAllTyFlag -> TyVar -> TyConBinder -- The odd argument order supports currying mkNamedTyConBinder vis tv = assert (isTyVar tv) $ Bndr tv (NamedTCB vis) -mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] +mkNamedTyConBinders :: ForAllTyFlag -> [TyVar] -> [TyConBinder] -- The odd argument order supports currying mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs @@ -483,15 +488,16 @@ mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently -> TyConBinder mkRequiredTyConBinder dep_set tv | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv - | otherwise = mkAnonTyConBinder VisArg tv + | otherwise = mkAnonTyConBinder tv -tyConBinderArgFlag :: TyConBinder -> ArgFlag -tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis +tyConBinderForAllTyFlag :: TyConBinder -> ForAllTyFlag +tyConBinderForAllTyFlag (Bndr _ vis) = tyConBndrVisForAllTyFlag vis -tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag -tyConBndrVisArgFlag (NamedTCB vis) = vis -tyConBndrVisArgFlag (AnonTCB VisArg) = Required -tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] +tyConBndrVisForAllTyFlag :: TyConBndrVis -> ForAllTyFlag +tyConBndrVisForAllTyFlag (NamedTCB vis) = vis +tyConBndrVisForAllTyFlag (AnonTCB af) -- See Note [AnonTCB with constraint arg] + | isVisibleFunArg af = Required + | otherwise = Inferred isNamedTyConBinder :: TyConBinder -> Bool -- Identifies kind variables @@ -505,9 +511,8 @@ isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis isVisibleTcbVis :: TyConBndrVis -> Bool -isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis -isVisibleTcbVis (AnonTCB VisArg) = True -isVisibleTcbVis (AnonTCB InvisArg) = False +isVisibleTcbVis (NamedTCB vis) = isVisibleForAllTyFlag vis +isVisibleTcbVis (AnonTCB af) = isVisibleFunArg af isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool -- Works for IfaceTyConBinder too @@ -519,8 +524,16 @@ mkTyConKind :: [TyConBinder] -> Kind -> Kind mkTyConKind bndrs res_kind = foldr mk res_kind bndrs where mk :: TyConBinder -> Kind -> Kind - mk (Bndr tv (AnonTCB af)) k = mkFunTyMany af (varType tv) k - mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k + mk (Bndr tv (NamedTCB vis)) k = mkForAllTy (Bndr tv vis) k + mk (Bndr tv (AnonTCB af)) k = mkNakedKindFunTy af (varType tv) k + -- mkNakedKindFunTy: see Note [Naked FunTy] in GHC.Builtin.Types + +-- | (mkTyConTy tc) returns (TyConApp tc []) +-- but arranges to share that TyConApp among all calls +-- See Note [Sharing nullary TyConApps] +-- So it's just an alias for tyConNullaryTy! +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = tyConNullaryTy tycon tyConInvisTVBinders :: [TyConBinder] -- From the TyCon -> [InvisTVBinder] -- Suitable for the foralls of a term function @@ -531,8 +544,9 @@ tyConInvisTVBinders tc_bndrs mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv where vis = case tc_vis of - AnonTCB VisArg -> SpecifiedSpec - AnonTCB InvisArg -> InferredSpec -- See Note [AnonTCB InvisArg] + AnonTCB af -- Note [AnonTCB with constraint arg] + | isInvisibleFunArg af -> InferredSpec + | otherwise -> SpecifiedSpec NamedTCB Required -> SpecifiedSpec NamedTCB (Invisible vis) -> vis @@ -542,10 +556,10 @@ tyConVisibleTyVars tc = [ tv | Bndr tv vis <- tyConBinders tc , isVisibleTcbVis vis ] -{- Note [AnonTCB InvisArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's pretty rare to have an (AnonTCB InvisArg) binder. The -only way it can occur is through equality constraints in kinds. These +{- Note [AnonTCB with constraint arg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's pretty rare to have an (AnonTCB af) binder with af=FTF_C_T or FTF_C_C. +The only way it can occur is through equality constraints in kinds. These can arise in one of two ways: * In a PromotedDataCon whose kind has an equality constraint: @@ -554,19 +568,20 @@ can arise in one of two ways: See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and Note [Promoted data constructors] in this module. + * In a data type whose kind has an equality constraint, as in the following example from #12102: data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type -When mapping an (AnonTCB InvisArg) to an ArgFlag, in -tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot +When mapping an (AnonTCB FTF_C_x) to an ForAllTyFlag, in +tyConBndrVisForAllTyFlag, we use "Inferred" to mean "the user cannot specify this arguments, even with visible type/kind application; instead the type checker must fill it in. -We map (AnonTCB VisArg) to Required, of course: the user must +We map (AnonTCB FTF_T_x) to Required, of course: the user must provide it. It would be utterly wrong to do this for constraint -arguments, which is why AnonTCB must have the AnonArgFlag in +arguments, which is why AnonTCB must have the FunTyFlag in the first place. Note [Building TyVarBinders from TyConBinders] @@ -578,12 +593,12 @@ TyConBinders but TyVarBinders (used in forall-type) E.g: * From data T a = MkT (Maybe a) we are going to make a data constructor with type MkT :: forall a. Maybe a -> T a - See the TyCoVarBinders passed to buildDataCon + See the ForAllTyBinders passed to buildDataCon * From class C a where { op :: a -> Maybe a } we are going to make a default method $dmop :: forall a. C a => a -> Maybe a - See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType + See the ForAllTyBinders passed to mkSigmaTy in mkDefaultMethodType Both of these are user-callable. (NB: default methods are not callable directly by the user but rather via the code generated by 'deriving', @@ -604,7 +619,7 @@ The TyConBinders for App line up with App's kind, given above. But the DataCon MkApp has the type MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b -That is, its TyCoVarBinders should be +That is, its ForAllTyBinders should be dataConUnivTyVarBinders = [ Bndr (k:*) Inferred , Bndr (a:k->*) Specified @@ -617,15 +632,15 @@ So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: The last part about Required->Specified comes from this: data T k (a:k) b = MkT (a b) Here k is Required in T's kind, but we don't have Required binders in -the TyCoBinders for a term (see Note [No Required TyCoBinder in terms] -in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's TyCoBinders +the PiTyBinders for a term (see Note [No Required PiTyBinder in terms] +in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's PiTyBinders -} {- Note [The binders/kind/arity fields of a TyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ All TyCons have this group of fields - tyConBinders :: [TyConBinder/TyConTyCoBinder] + tyConBinders :: [TyConBinder/TyConPiTyBinder] tyConResKind :: Kind tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders -- NB: Currently (Aug 2018), TyCons that own this @@ -650,7 +665,7 @@ They fit together like so: See Note [tyConBinders and lexical scoping] -* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep +* See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for what the visibility flag means. * Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and @@ -722,13 +737,7 @@ Why do we have this invariant? -} instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where - ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v) - where - ppr_bi (AnonTCB VisArg) = text "anon-vis" - ppr_bi (AnonTCB InvisArg) = text "anon-invis" - ppr_bi (NamedTCB Required) = text "req" - ppr_bi (NamedTCB Specified) = text "spec" - ppr_bi (NamedTCB Inferred) = text "inf" + ppr (Bndr v bi) = ppr bi <+> parens (pprBndr LetBind v) instance Binary TyConBndrVis where put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } @@ -767,25 +776,7 @@ instance Binary TyConBndrVis where -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in GHC.Core.Lint -data TyCon - = -- | The function type constructor, @(->)@ - FunTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, - - tcRepName :: TyConRepName - } - +data TyCon = -- | Algebraic data types, from -- - @data@ declarations -- - @newtype@ declarations @@ -798,10 +789,10 @@ data TyCon -- - unboxed sums -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. -- See 'AlgTyConRhs' for more information. - | AlgTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. + AlgTyCon { + tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. tyConName :: Name, -- ^ Name of the constructor @@ -860,9 +851,9 @@ data TyCon -- | Represents type synonyms | SynonymTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. + tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. tyConName :: Name, -- ^ Name of the constructor @@ -899,7 +890,7 @@ data TyCon -- | Represents families (both type and data) -- Argument roles are all Nominal | FamilyTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant: -- identical to Unique of Name stored in -- tyConName field. @@ -937,9 +928,9 @@ data TyCon -- the usual suspects (such as @Int#@) as well as foreign-imported -- types and kinds (@*@, @#@, and @?@) | PrimTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. + tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. tyConName :: Name, -- ^ Name of the constructor @@ -961,12 +952,12 @@ data TyCon -- | Represents promoted data constructor. | PromotedDataCon { -- See Note [Promoted data constructors] - tyConUnique :: Unique, -- ^ Same Unique as the data constructor + tyConUnique :: !Unique, -- ^ Same Unique as the data constructor tyConName :: Name, -- ^ Same Name as the data constructor -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConTyCoBinder], -- ^ Full binders - -- TyConTyCoBinder: see Note [Promoted GADT data constructors] + tyConBinders :: [TyConPiTyBinder], -- ^ Full binders + -- TyConPiTyBinder: see Note [Promoted GADT data constructors] tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity @@ -975,13 +966,13 @@ data TyCon tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars dataCon :: DataCon, -- ^ Corresponding data constructor tcRepName :: TyConRepName, - promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' + promDcInfo :: PromDataConInfo -- ^ See comments with 'PromDataConInfo' } -- | These exist only during type-checking. See Note [How TcTyCons work] -- in "GHC.Tc.TyCl" | TcTyCon { - tyConUnique :: Unique, + tyConUnique :: !Unique, tyConName :: Name, -- See Note [The binders/kind/arity fields of a TyCon] @@ -1033,8 +1024,8 @@ constraints in its type; e.g. K :: forall a b. (a ~# [b]) => a -> b -> T a So, when promoted to become a type constructor, the tyConBinders -will include CoVars. That is why we use [TyConTyCoBinder] for the -tyconBinders field. TyConTyCoBinder is a synonym for TyConBinder, +will include CoVars. That is why we use [TyConPiTyBinder] for the +tyconBinders field. TyConPiTyBinder is a synonym for TyConBinder, but with the clue that the binder can be a CoVar not just a TyVar. Note [Representation-polymorphic TyCons] @@ -1251,20 +1242,22 @@ mkDataTyConRhs :: [DataCon] -> AlgTyConRhs mkDataTyConRhs = mkLevPolyDataTyConRhs True False -- | Some promoted datacons signify extra info relevant to GHC. For example, --- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' +-- the `IntRep` constructor of `RuntimeRep` corresponds to the 'IntRep' -- constructor of 'PrimRep'. This data structure allows us to store this -- information right in the 'TyCon'. The other approach would be to look --- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. +-- up things like `RuntimeRep`'s `PrimRep` by known-key every time. -- See also Note [Getting from RuntimeRep to PrimRep] in "GHC.Types.RepType" -data RuntimeRepInfo - = NoRRI -- ^ an ordinary promoted data con +data PromDataConInfo + = NoPromInfo -- ^ an ordinary promoted data con | RuntimeRep ([Type] -> [PrimRep]) - -- ^ A constructor of @RuntimeRep@. The argument to the function should + -- ^ A constructor of `RuntimeRep`. The argument to the function should -- be the list of arguments to the promoted datacon. - | VecCount Int -- ^ A constructor of @VecCount@ - | VecElem PrimElemRep -- ^ A constructor of @VecElem@ - | LiftedInfo -- ^ A constructor of @Levity@ - | UnliftedInfo -- ^ A constructor of @Levity@ + + | VecCount Int -- ^ A constructor of `VecCount` + + | VecElem PrimElemRep -- ^ A constructor of `VecElem` + + | Levity Levity -- ^ A constructor of `Levity` -- | Extract those 'DataCon's that we are able to learn about. Note -- that visibility in this sense does not correspond to visibility in @@ -1419,8 +1412,8 @@ All data constructors can be promoted to become a type constructor, via the PromotedDataCon alternative in GHC.Core.TyCon. * The TyCon promoted from a DataCon has the *same* Name and Unique as - the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, - say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) + the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78) + is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) * We promote the *user* type of the DataCon. Eg data T = MkT {-# UNPACK #-} !(Bool, Bool) @@ -1522,8 +1515,6 @@ type TyConRepName = Name -- $tcMaybe = TyCon { tyConName = "Maybe", ... } tyConRepName_maybe :: TyCon -> Maybe TyConRepName -tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) - = Just rep_nm tyConRepName_maybe (PrimTyCon { primRepName = rep_nm }) = Just rep_nm tyConRepName_maybe (AlgTyCon { algTcFlavour = parent }) = case parent of @@ -1842,24 +1833,6 @@ module mutual-recursion. And they aren't called from many places. So we compromise, and move their Kind calculation to the call site. -} --- | Given the name of the function type constructor and it's kind, create the --- corresponding 'TyCon'. It is recommended to use 'GHC.Builtin.Types.funTyCon' if you want --- this functionality -mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon -mkFunTyCon name binders rep_nm - = let tc = - FunTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConResKind = liftedTypeKind, - tyConKind = mkTyConKind binders liftedTypeKind, - tyConArity = length binders, - tyConNullaryTy = mkNakedTyConTy tc, - tcRepName = rep_nm - } - in tc - -- | This is the making of an algebraic 'TyCon'. mkAlgTyCon :: Name -> [TyConBinder] -- ^ Binders of the 'TyCon' @@ -2071,8 +2044,8 @@ mkFamilyTyCon name binders res_kind resVar flav parent inj -- as the data constructor itself; when we pretty-print -- the TyCon we add a quote; see the Outputable TyCon instance mkPromotedDataCon :: DataCon -> Name -> TyConRepName - -> [TyConTyCoBinder] -> Kind -> [Role] - -> RuntimeRepInfo -> TyCon + -> [TyConPiTyBinder] -> Kind -> [Role] + -> PromDataConInfo -> TyCon mkPromotedDataCon con name rep_name binders res_kind roles rep_info = let tc = PromotedDataCon { @@ -2086,14 +2059,10 @@ mkPromotedDataCon con name rep_name binders res_kind roles rep_info tyConKind = mkTyConKind binders res_kind, dataCon = con, tcRepName = rep_name, - promDcRepInfo = rep_info + promDcInfo = rep_info } in tc -isFunTyCon :: TyCon -> Bool -isFunTyCon (FunTyCon {}) = True -isFunTyCon _ = False - -- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) isAbstractTyCon :: TyCon -> Bool isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon {} }) = True @@ -2116,16 +2085,6 @@ isVanillaAlgTyCon :: TyCon -> Bool isVanillaAlgTyCon (AlgTyCon { algTcFlavour = VanillaAlgTyCon _ }) = True isVanillaAlgTyCon _ = False --- | Returns @True@ for the 'TyCon' of the 'Constraint' kind. -{-# INLINE isConstraintKindCon #-} -- See Note [Inlining coreView] in GHC.Core.Type -isConstraintKindCon :: TyCon -> Bool --- NB: We intentionally match on AlgTyCon, because 'constraintKindTyCon' is --- always an AlgTyCon (see 'pcTyCon' in TysWiredIn) and the record selector --- for 'tyConUnique' would generate unreachable code for every other data --- constructor of TyCon (see #18026). -isConstraintKindCon AlgTyCon { tyConUnique = u } = u == constraintKindTyConKey -isConstraintKindCon _ = False - isDataTyCon :: TyCon -> Bool -- ^ Returns @True@ for data types that are /definitely/ represented by -- heap-allocated constructors. These are scrutinised by Core-level @@ -2165,7 +2124,6 @@ isTypeDataTyCon _ = False -- See also Note [Decomposing equality] in "GHC.Tc.Solver.Canonical" isInjectiveTyCon :: TyCon -> Role -> Bool isInjectiveTyCon _ Phantom = False -isInjectiveTyCon (FunTyCon {}) _ = True isInjectiveTyCon (AlgTyCon {}) Nominal = True isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational = isGenInjAlgRhs rhs @@ -2258,11 +2216,11 @@ isForgetfulSynTyCon _ = False -- (T ~N d), (a ~N e) and (b ~N f)? -- Specifically NOT true of synonyms (open and otherwise) -- --- It'd be unusual to call mustBeSaturated on a regular H98 +-- It'd be unusual to call tyConMustBeSaturated on a regular H98 -- type synonym, because you should probably have expanded it first -- But regardless, it's not decomposable -mustBeSaturated :: TyCon -> Bool -mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour +tyConMustBeSaturated :: TyCon -> Bool +tyConMustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour -- | Is this an algebraic 'TyCon' declared with the GADT syntax? isGadtSyntaxTyCon :: TyCon -> Bool @@ -2458,7 +2416,6 @@ isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) -- (namely: boxed and unboxed tuples are wired-in and implicit, -- but constraint tuples are not) isImplicitTyCon :: TyCon -> Bool -isImplicitTyCon (FunTyCon {}) = True isImplicitTyCon (PrimTyCon {}) = True isImplicitTyCon (PromotedDataCon {}) = True isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) @@ -2498,7 +2455,6 @@ setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) -- -- See Note [Representation-polymorphic TyCons] tcHasFixedRuntimeRep :: TyCon -> Bool -tcHasFixedRuntimeRep FunTyCon{} = True tcHasFixedRuntimeRep (AlgTyCon { algTcRhs = rhs }) = case rhs of AbstractTyCon {} -> False -- An abstract TyCon might not have a fixed runtime representation. @@ -2688,8 +2644,7 @@ tyConRoles :: TyCon -> [Role] -- See also Note [TyCon Role signatures] tyConRoles tc = case tc of - { FunTyCon {} -> [Nominal, Nominal, Nominal, Representational, Representational] - ; AlgTyCon { tcRoles = roles } -> roles + { AlgTyCon { tcRoles = roles } -> roles ; SynonymTyCon { tcRoles = roles } -> roles ; FamilyTyCon {} -> const_role Nominal ; PrimTyCon { tcRoles = roles } -> roles @@ -2741,7 +2696,7 @@ newTyConDataCon_maybe _ = Nothing -- @data Eq a => T a ...@. See @Note [The stupid context]@ in "GHC.Core.DataCon". tyConStupidTheta :: TyCon -> [PredType] tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid -tyConStupidTheta (FunTyCon {}) = [] +tyConStupidTheta (PrimTyCon {}) = [] tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) -- | Extract the 'TyVar's bound by a vanilla type synonym @@ -2807,9 +2762,9 @@ tyConFamilyCoercion_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ }) tyConFamilyCoercion_maybe _ = Nothing -- | Extract any 'RuntimeRepInfo' from this TyCon -tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo -tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri -tyConRuntimeRepInfo _ = NoRRI +tyConPromDataConInfo :: TyCon -> PromDataConInfo +tyConPromDataConInfo (PromotedDataCon { promDcInfo = rri }) = rri +tyConPromDataConInfo _ = NoPromInfo -- could panic in that second case. But Douglas Adams told me not to. {- @@ -2916,7 +2871,6 @@ tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour -tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav diff --git a/compiler/GHC/Core/TyCon.hs-boot b/compiler/GHC/Core/TyCon.hs-boot index 21a54508b3..3482e06f12 100644 --- a/compiler/GHC/Core/TyCon.hs-boot +++ b/compiler/GHC/Core/TyCon.hs-boot @@ -14,7 +14,6 @@ type TyConRepName = Name isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool -isFunTyCon :: TyCon -> Bool tyConRepName_maybe :: TyCon -> Maybe TyConRepName mkPrelTyConRepName :: Name -> TyConRepName diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index b6b2dd369c..a36a398773 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -3,8 +3,7 @@ -- -- Type - public interface -{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -16,43 +15,45 @@ module GHC.Core.Type ( -- $type_classification -- $representation_types - Type, ArgFlag(..), AnonArgFlag(..), + Type, ForAllTyFlag(..), FunTyFlag(..), Specificity(..), KindOrType, PredType, ThetaType, FRRType, - Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, + Var, TyVar, isTyVar, TyCoVar, PiTyBinder, ForAllTyBinder, TyVarBinder, Mult, Scaled, - KnotTied, + KnotTied, RuntimeRepType, -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, getCastedTyVar_maybe, tyVarKind, varType, - mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, - splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTysNoView, + splitAppTy_maybe, splitAppTyNoView_maybe, tcSplitAppTyNoView_maybe, - mkFunTy, mkVisFunTy, mkInvisFunTy, - mkVisFunTys, - mkVisFunTyMany, mkInvisFunTyMany, - mkVisFunTysMany, mkInvisFunTysMany, + mkFunTy, mkVisFunTy, + mkVisFunTyMany, mkVisFunTysMany, + mkScaledFunTys, + mkInvisFunTy, mkInvisFunTys, + tcMkVisFunTy, tcMkScaledFunTys, tcMkInvisFunTy, splitFunTy, splitFunTy_maybe, splitFunTys, funResultTy, funArgTy, + funTyConAppTy_maybe, funTyFlagTyCon, + tyConAppFunTy_maybe, tyConAppFunCo_maybe, + mkFunctionType, mkScaledFunctionTys, chooseFunTyFlag, - mkTyConApp, mkTyConTy, mkTYPEapp, + mkTyConApp, mkTyConTy, tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, - splitTyConApp_maybe, splitTyConApp, tyConAppArgN, - tcSplitTyConApp_maybe, - splitListTyConApp_maybe, - repSplitTyConApp_maybe, - tcRepSplitTyConApp_maybe, + + splitTyConApp_maybe, splitTyConAppNoView_maybe, splitTyConApp, + tcSplitTyConApp, tcSplitTyConApp_maybe, mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, mkSpecForAllTy, mkSpecForAllTys, mkVisForAllTys, mkTyCoInvForAllTy, mkInfForAllTy, mkInfForAllTys, splitForAllTyCoVars, - splitForAllReqTVBinders, splitForAllInvisTVBinders, - splitForAllTyCoVarBinders, + splitForAllReqTyBinders, splitForAllInvisTyBinders, + splitForAllForAllTyBinders, splitForAllTyCoVar_maybe, splitForAllTyCoVar, splitForAllTyVar_maybe, splitForAllCoVar_maybe, splitPiTy_maybe, splitPiTy, splitPiTys, @@ -71,7 +72,8 @@ module GHC.Core.Type ( isPredTy, - getRuntimeRep_maybe, kindRep_maybe, kindRep, + getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep, + getLevity, levityType_maybe, mkCastTy, mkCoercionTy, splitCastTy_maybe, @@ -84,7 +86,7 @@ module GHC.Core.Type ( invisibleTyBndrCount, filterOutInvisibleTypes, filterOutInferredTypes, partitionInvisibleTypes, partitionInvisibles, - tyConArgFlags, appTyArgFlags, + tyConForAllTyFlags, appTyForAllTyFlags, -- ** Analyzing types TyCoMapper(..), mapTyCo, mapTyCoX, @@ -94,22 +96,16 @@ module GHC.Core.Type ( newTyConInstRhs, -- ** Binders - sameVis, - mkTyCoVarBinder, mkTyCoVarBinders, + mkForAllTyBinder, mkForAllTyBinders, mkTyVarBinder, mkTyVarBinders, tyVarSpecToBinders, - mkAnonBinder, - isAnonTyCoBinder, - binderVar, binderVars, binderType, binderArgFlag, - tyCoBinderType, tyCoBinderVar_maybe, - tyBinderType, - binderRelevantType_maybe, - isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, - isInvisibleBinder, isNamedBinder, - tyConBindersTyCoBinders, - - -- ** Common type constructors - funTyCon, unrestrictedFunTyCon, + isAnonPiTyBinder, + binderVar, binderVars, binderType, binderFlag, binderFlags, + piTyBinderType, namedPiTyBinder_maybe, + anonPiTyBinderType_maybe, + isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isVisiblePiTyBinder, + isInvisiblePiTyBinder, isNamedPiTyBinder, + tyConBindersPiTyBinders, -- ** Predicates on types isTyVarTy, isFunTy, isCoercionTy, @@ -121,7 +117,14 @@ module GHC.Core.Type ( isValidJoinPointType, tyConAppNeedsKindSig, + -- * Space-saving construction + mkTYPEapp, mkTYPEapp_maybe, + mkCONSTRAINTapp, mkCONSTRAINTapp_maybe, + mkBoxedRepApp_maybe, mkTupleRepApp_maybe, + typeOrConstraintKind, + -- *** Levity and boxity + sORTKind_maybe, typeTypeOrConstraint, typeLevity_maybe, isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind, isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe, @@ -135,24 +138,24 @@ module GHC.Core.Type ( isLevityTy, isLevityVar, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, dropRuntimeRepArgs, - getRuntimeRep, getLevity, getLevity_maybe, -- * Multiplicity isMultiplicityTy, isMultiplicityVar, unrestricted, linear, tymult, mkScaled, irrelevantMult, scaledSet, - pattern One, pattern Many, - isOneDataConTy, isManyDataConTy, + pattern OneTy, pattern ManyTy, + isOneTy, isManyTy, isLinearType, -- * Main data types representing Kinds Kind, -- ** Finding the kind of a type - typeKind, tcTypeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep, - tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, - tcIsBoxedTypeKind, tcIsRuntimeTypeKind, + typeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep, + tcIsLiftedTypeKind, + isConstraintKind, isConstraintLikeKind, returnsConstraintKind, + tcIsBoxedTypeKind, isTypeLikeKind, -- ** Common Kind liftedTypeKind, unliftedTypeKind, @@ -166,7 +169,6 @@ module GHC.Core.Type ( anyFreeVarsOfType, anyFreeVarsOfTypes, noFreeVarsOfType, - splitVisVarsOfType, splitVisVarsOfTypes, expandTypeSynonyms, typeSize, occCheckExpand, @@ -178,16 +180,11 @@ module GHC.Core.Type ( scopedSort, tyCoVarsOfTypeWellScoped, tyCoVarsOfTypesWellScoped, - -- * Type comparison - eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, - nonDetCmpTypesX, nonDetCmpTc, - eqVarBndrs, - -- * Forcing evaluation of types seqType, seqTypes, -- * Other views onto Types - coreView, tcView, + coreView, tyConsOfType, @@ -222,7 +219,7 @@ module GHC.Core.Type ( substCo, substCoUnchecked, substCoWithUnchecked, substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, substVarBndr, substVarBndrs, - substTyCoBndr, + substTyCoBndr, substTyVarToTyVar, cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, -- * Tidying type related things up for printing @@ -232,11 +229,10 @@ module GHC.Core.Type ( tidyOpenTyCoVar, tidyOpenTyCoVars, tidyTyCoVarOcc, tidyTopType, - tidyTyCoVarBinder, tidyTyCoVarBinders, + tidyForAllTyBinder, tidyForAllTyBinders, -- * Kinds - isConstraintKindCon, - classifiesTypeWithValues, + isTYPEorCONSTRAINT, isConcrete, isFixedRuntimeRepKind, ) where @@ -260,24 +256,25 @@ import GHC.Types.Unique.Set import GHC.Core.TyCon import GHC.Builtin.Types.Prim + import {-# SOURCE #-} GHC.Builtin.Types - ( charTy, naturalTy, listTyCon - , typeSymbolKind, liftedTypeKind, unliftedTypeKind - , liftedRepTy, unliftedRepTy, zeroBitRepTy - , boxedRepDataConTyCon - , constraintKind, zeroBitTypeKind - , unrestrictedFunTyCon - , manyDataConTy, oneDataConTy ) + ( charTy, naturalTy + , typeSymbolKind, liftedTypeKind, unliftedTypeKind + , boxedRepDataConTyCon, constraintKind, zeroBitTypeKind + , manyDataConTy, oneDataConTy + , liftedRepTy, unliftedRepTy, zeroBitRepTy ) + import GHC.Types.Name( Name ) import GHC.Builtin.Names import GHC.Core.Coercion.Axiom + import {-# SOURCE #-} GHC.Core.Coercion ( mkNomReflCo, mkGReflCo, mkReflCo - , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo - , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo - , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo - , mkKindCo, mkSubCo - , decomposePiCos, coercionKind, coercionLKind + , mkTyConAppCo, mkAppCo + , mkForAllCo, mkFunCo2, mkAxiomInstCo, mkUnivCo + , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo + , mkKindCo, mkSubCo, mkFunCo1 + , decomposePiCos, coercionKind , coercionRKind, coercionType , isReflexiveCo, seqCo , topNormaliseNewType_maybe @@ -291,14 +288,9 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString -import GHC.Data.Pair -import GHC.Data.List.SetOps -import GHC.Types.Unique ( nonDetCmpUnique ) -import GHC.Base (reallyUnsafePtrEquality#) -import GHC.Data.Maybe ( orElse, expectJust, isJust ) import Control.Monad ( guard ) -import qualified Data.Semigroup as S +import GHC.Data.Maybe ( orElse, isJust ) -- $type_classification -- #type_classification# @@ -367,108 +359,60 @@ import qualified Data.Semigroup as S Type representation * * ************************************************************************ - -Note [coreView vs tcView] -~~~~~~~~~~~~~~~~~~~~~~~~~ -So far as the typechecker is concerned, 'Constraint' and 'TYPE -LiftedRep' are distinct kinds. - -But in Core these two are treated as identical. - -We implement this by making 'coreView' convert 'Constraint' to 'TYPE -LiftedRep' on the fly. The function tcView (used in the type checker) -does not do this. Accordingly, tcView is used in type-checker-oriented -functions (including the pure unifier, used in instance resolution), -while coreView is used during e.g. optimisation passes. - -See also #11715, which tracks removing this inconsistency. - -In order to prevent users from discerning between Type and Constraint -(which could create inconsistent axioms -- see #21092), we say that -Type and Constraint are not SurelyApart in the pure unifier. See -GHC.Core.Unify.unify_ty, where this case produces MaybeApart. - -One annoying consequence of this inconsistency is that we can get ill-kinded -updates to metavariables. #20356 is a case in point. Simplifying somewhat, -we end up with - [W] (alpha :: Constraint) ~ (Int :: Type) -This is heterogeneous, so we produce - [W] co :: (Constraint ~ Type) -and transform our original wanted to become - [W] alpha ~ Int |> sym co -in accordance with Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical. -Our transformed wanted is now homogeneous (both sides have kind Constraint) -and so we unify alpha := Int |> sym co. - -However, it's not so easy: when we build the cast (Int |> sym co), we actually -just get Int back. This is because we forbid reflexive casts (invariant (EQ2) of -Note [Respecting definitional equality] in GHC.Core.TyCo.Rep), and co looks -reflexive: it relates Type and Constraint, even though these are considered -identical in Core. Above, when we tried to say alpha := Int |> sym co, we -really ended up doing alpha := Int -- even though alpha :: Constraint and -Int :: Type have different kinds. Nothing has really gone wrong, though: -we still emitted [W] co :: (Constraint ~ Type), which will be insoluble -and lead to a decent error message. We simply need not to fall over at the -moment of unification, because all will be OK in the end. We thus use the -Core eqType, not the Haskell tcEqType, in the kind check for a meta-tyvar -unification in GHC.Tc.Utils.TcMType.writeMetaTyVarRef. - -} --- | Gives the typechecker view of a type. This unwraps synonyms but --- leaves 'Constraint' alone. c.f. 'coreView', which turns 'Constraint' into --- 'Type'. Returns 'Nothing' if no unwrapping happens. --- See also Note [coreView vs tcView] -tcView :: Type -> Maybe Type -tcView (TyConApp tc tys) - | res@(Just _) <- expandSynTyConApp_maybe tc tys - = res -tcView _ = Nothing --- See Note [Inlining coreView]. -{-# INLINE tcView #-} - coreView :: Type -> Maybe Type -- ^ This function strips off the /top layer only/ of a type synonym -- application (if any) its underlying representation type. -- Returns 'Nothing' if there is nothing to look through. --- This function considers 'Constraint' to be a synonym of @Type@. -- -- This function does not look through type family applications. -- -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing -coreView ty@(TyConApp tc tys) - | res@(Just _) <- expandSynTyConApp_maybe tc tys - = res - - -- At the Core level, Constraint = Type - -- See Note [coreView vs tcView] - | isConstraintKindCon tc - = assertPpr (null tys) (ppr ty) $ - Just liftedTypeKind - -coreView _ = Nothing +coreView (TyConApp tc tys) = expandSynTyConApp_maybe tc tys +coreView _ = Nothing -- See Note [Inlining coreView]. {-# INLINE coreView #-} ------------------------------------------------ +coreFullView, core_full_view :: Type -> Type +-- ^ Iterates 'coreView' until there is no more to synonym to expand. +-- NB: coreFullView is non-recursive and can be inlined; +-- core_full_view is the recursive one +-- See Note [Inlining coreView]. +coreFullView ty@(TyConApp tc _) + | isTypeSynonymTyCon tc = core_full_view ty +coreFullView ty = ty +{-# INLINE coreFullView #-} + +core_full_view ty + | Just ty' <- coreView ty = core_full_view ty' + | otherwise = ty +----------------------------------------------- -- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@ -- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a -- synonym. expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type {-# INLINE expandSynTyConApp_maybe #-} -- This INLINE will inline the call to expandSynTyConApp_maybe in coreView, --- which will eliminate the allocat ion Just/Nothing in the result --- Don't be tempted to make `expand_syn` (which is NOINLIN) return the +-- which will eliminate the allocation Just/Nothing in the result +-- Don't be tempted to make `expand_syn` (which is NOINLINE) return the -- Just/Nothing, else you'll increase allocation expandSynTyConApp_maybe tc arg_tys | Just (tvs, rhs) <- synTyConDefn_maybe tc - , arg_tys `lengthAtLeast` (tyConArity tc) + , arg_tys `saturates` tyConArity tc = Just (expand_syn tvs rhs arg_tys) | otherwise = Nothing +saturates :: [Type] -> Arity -> Bool +saturates _ 0 = True +saturates [] _ = False +saturates (_:tys) n = assert( n >= 0 ) $ saturates tys (n-1) + -- Arities are always positive; the assertion just checks + -- that, to avoid an ininite loop in the bad case + -- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path -- into call-sites. -- @@ -508,21 +452,6 @@ expand_syn tvs rhs arg_tys go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys) -- Under-saturated, precondition failed - - -coreFullView :: Type -> Type --- ^ Iterates 'coreView' until there is no more to synonym to expand. --- See Note [Inlining coreView]. -coreFullView ty@(TyConApp tc _) - | isTypeSynonymTyCon tc || isConstraintKindCon tc = go ty - where - go ty - | Just ty' <- coreView ty = go ty' - | otherwise = ty - -coreFullView ty = ty -{-# INLINE coreFullView #-} - {- Note [Inlining coreView] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is very common to have a function @@ -541,7 +470,13 @@ in its fast path. For this to really be fast, all calls made on its fast path must also be inlined, linked back to this Note. -} ------------------------------------------------ + +{- ********************************************************************* +* * + expandTypeSynonyms +* * +********************************************************************* -} + expandTypeSynonyms :: Type -> Type -- ^ Expand out all type synonyms. Actually, it'd suffice to expand out -- just the ones that discard type variables (e.g. type Funny a = Int) @@ -598,8 +533,8 @@ expandTypeSynonyms ty go_co subst (ForAllCo tv kind_co co) = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in mkForAllCo tv' kind_co' (go_co subst' co) - go_co subst (FunCo r w co1 co2) - = mkFunCo r (go_co subst w) (go_co subst co1) (go_co subst co2) + go_co subst (FunCo r afl afr w co1 co2) + = mkFunCo2 r afl afr (go_co subst w) (go_co subst co1) (go_co subst co2) go_co subst (CoVarCo cv) = substCoVar subst cv go_co subst (AxiomInstCo ax ind args) @@ -610,8 +545,8 @@ expandTypeSynonyms ty = mkSymCo (go_co subst co) go_co subst (TransCo co1 co2) = mkTransCo (go_co subst co1) (go_co subst co2) - go_co subst (NthCo r n co) - = mkNthCo r n (go_co subst co) + go_co subst (SelCo n co) + = mkSelCo n (go_co subst co) go_co subst (LRCo lr co) = mkLRCo lr (go_co subst co) go_co subst (InstCo co arg) @@ -636,6 +571,27 @@ expandTypeSynonyms ty -- order of a coercion) go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst +{- Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms wherever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind. +-} + +{- ********************************************************************* +* * + Random functions (todo: organise) +* * +********************************************************************* -} + -- | An INLINE helper for function such as 'kindRep_maybe' below. -- -- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff @@ -657,24 +613,31 @@ kindRep k = case kindRep_maybe k of Just r -> r Nothing -> pprPanic "kindRep" (ppr k) --- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. +-- | Given a kind (TYPE rr) or (CONSTRAINT rr), extract its RuntimeRep classifier rr. -- For example, @kindRep_maybe * = Just LiftedRep@ -- Returns 'Nothing' if the kind is not of form (TYPE rr) --- Treats * and Constraint as the same kindRep_maybe :: HasDebugCallStack => Kind -> Maybe RuntimeRepType kindRep_maybe kind - | Just [arg] <- isTyConKeyApp_maybe tYPETyConKey kind = Just arg - | otherwise = Nothing + | Just (_, rep) <- sORTKind_maybe kind = Just rep + | otherwise = Nothing --- | This version considers Constraint to be the same as *. Returns True --- if the argument is equivalent to Type/Constraint and False otherwise. --- See Note [Kind Constraint and kind Type] +-- | Returns True if the argument is (lifted) Type or Constraint +-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim isLiftedTypeKind :: Kind -> Bool isLiftedTypeKind kind = case kindRep_maybe kind of Just rep -> isLiftedRuntimeRep rep Nothing -> False +-- | Returns True if the kind classifies unlifted types (like 'Int#') and False +-- otherwise. Note that this returns False for representation-polymorphic +-- kinds, which may be specialized to a kind that classifies unlifted types. +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isUnliftedRuntimeRep rep + Nothing -> False + pickyIsLiftedTypeKind :: Kind -> Bool -- Checks whether the kind is literally -- TYPE LiftedRep @@ -698,62 +661,14 @@ pickyIsLiftedTypeKind kind , tc `hasKey` liftedTypeKindTyConKey = True | otherwise = False --- | Returns True if the kind classifies unlifted types (like 'Int#') and False --- otherwise. Note that this returns False for representation-polymorphic --- kinds, which may be specialized to a kind that classifies unlifted types. -isUnliftedTypeKind :: Kind -> Bool -isUnliftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isUnliftedRuntimeRep rep - Nothing -> False - --- | See 'isBoxedRuntimeRep_maybe'. -isBoxedRuntimeRep :: Type -> Bool -isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep) - --- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep` --- expands to `Boxed lev` and returns `Nothing` otherwise. --- --- Types with this runtime rep are represented by pointers on the GC'd heap. -isBoxedRuntimeRep_maybe :: Type -> Maybe Type -isBoxedRuntimeRep_maybe rep - | Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep - = Just lev - | otherwise - = Nothing - --- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown. --- --- @isLiftedRuntimeRep rr@ returns: --- --- * @Just Lifted@ if @rr@ is @LiftedRep :: RuntimeRep@ --- * @Just Unlifted@ if @rr@ is definitely unlifted, e.g. @IntRep@ --- * @Nothing@ if not known (e.g. it's a type variable or a type family application). -runtimeRepLevity_maybe :: Type -> Maybe Levity -runtimeRepLevity_maybe rep - | TyConApp rr_tc args <- coreFullView rep - , isPromotedDataCon rr_tc = - -- NB: args might be non-empty e.g. TupleRep [r1, .., rn] - if (rr_tc `hasKey` boxedRepDataConKey) - then case args of - [lev] | isLiftedLevity lev -> Just Lifted - | isUnliftedLevity lev -> Just Unlifted - _ -> Nothing - else Just Unlifted - -- Avoid searching all the unlifted RuntimeRep type cons - -- In the RuntimeRep data type, only LiftedRep is lifted - -- But be careful of type families (F tys) :: RuntimeRep, - -- hence the isPromotedDataCon rr_tc -runtimeRepLevity_maybe _ = Nothing - --- | Check whether a kind is of the form @TYPE (BoxedRep Lifted)@ --- or @TYPE (BoxedRep Unlifted)@. +-- | Check whether a kind is of the form `TYPE (BoxedRep Lifted)` +-- or `TYPE (BoxedRep Unlifted)`. -- -- Returns: -- --- - @Just Lifted@ for @TYPE (BoxedRep Lifted)@ and @Type@, --- - @Just Unlifted@ for @TYPE (BoxedRep Unlifted)@ and @UnliftedType@, --- - @Nothing@ for anything else, e.g. @TYPE IntRep@, @TYPE (BoxedRep l)@, etc. +-- - `Just Lifted` for `TYPE (BoxedRep Lifted)` and `Type`, +-- - `Just Unlifted` for `TYPE (BoxedRep Unlifted)` and `UnliftedType`, +-- - `Nothing` for anything else, e.g. `TYPE IntRep`, `TYPE (BoxedRep l)`, etc. kindBoxedRepLevity_maybe :: Type -> Maybe Levity kindBoxedRepLevity_maybe ty | Just rep <- kindRep_maybe ty @@ -769,7 +684,7 @@ kindBoxedRepLevity_maybe ty -- * True of @LiftedRep :: RuntimeRep@ -- * False of type variables, type family applications, -- and of other reps such as @IntRep :: RuntimeRep@. -isLiftedRuntimeRep :: Type -> Bool +isLiftedRuntimeRep :: RuntimeRepType -> Bool isLiftedRuntimeRep rep = runtimeRepLevity_maybe rep == Just Lifted @@ -779,7 +694,7 @@ isLiftedRuntimeRep rep = -- 'UnliftedRep', 'IntRep', 'FloatRep', ... -- * False of 'LiftedRep', -- * False for type variables and type family applications. -isUnliftedRuntimeRep :: Type -> Bool +isUnliftedRuntimeRep :: RuntimeRepType -> Bool isUnliftedRuntimeRep rep = runtimeRepLevity_maybe rep == Just Unlifted @@ -825,6 +740,81 @@ isMultiplicityTy = isNullaryTyConKeyApp multiplicityTyConKey isMultiplicityVar :: TyVar -> Bool isMultiplicityVar = isMultiplicityTy . tyVarKind +-------------------------------------------- +-- Splitting RuntimeRep +-------------------------------------------- + +-- | (splitRuntimeRep_maybe rr) takes a Type rr :: RuntimeRep, and +-- returns the (TyCon,[Type]) for the RuntimeRep, if possible, where +-- the TyCon is one of the promoted DataCons of RuntimeRep. +-- Remember: the unique on TyCon that is a a promoted DataCon is the +-- same as the unique on the DataCon +-- See Note [Promoted data constructors] in GHC.Core.TyCon +-- May not be possible if `rr` is a type variable or type +-- family application +splitRuntimeRep_maybe :: RuntimeRepType -> Maybe (TyCon, [Type]) +splitRuntimeRep_maybe rep + | TyConApp rr_tc args <- coreFullView rep + , isPromotedDataCon rr_tc + -- isPromotedDataCon: be careful of type families (F tys) :: RuntimeRep, + = Just (rr_tc, args) + | otherwise + = Nothing + +-- | See 'isBoxedRuntimeRep_maybe'. +isBoxedRuntimeRep :: RuntimeRepType -> Bool +isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep) + +-- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep` +-- expands to `Boxed lev` and returns `Nothing` otherwise. +-- +-- Types with this runtime rep are represented by pointers on the GC'd heap. +isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe Type +isBoxedRuntimeRep_maybe rep + | Just (rr_tc, args) <- splitRuntimeRep_maybe rep + , rr_tc `hasKey` boxedRepDataConKey + , [lev] <- args + = Just lev + | otherwise + = Nothing + +-- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown. +-- +-- `isLiftedRuntimeRep rr` returns: +-- +-- * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep` +-- * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep` +-- * `Nothing` if not known (e.g. it's a type variable or a type family application). +runtimeRepLevity_maybe :: RuntimeRepType -> Maybe Levity +runtimeRepLevity_maybe rep + | Just (rr_tc, args) <- splitRuntimeRep_maybe rep + = -- NB: args might be non-empty e.g. TupleRep [r1, .., rn] + if (rr_tc `hasKey` boxedRepDataConKey) + then case args of + [lev] -> levityType_maybe lev + _ -> pprPanic "runtimeRepLevity_maybe" (ppr rep) + else Just Unlifted + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + | otherwise + = Nothing + +-------------------------------------------- +-- Splitting Levity +-------------------------------------------- + +-- | `levity_maybe` takes a Type of kind Levity, and returns its levity +-- May not be possible for a type variable or type family application +levityType_maybe :: LevityType -> Maybe Levity +levityType_maybe lev + | TyConApp lev_tc args <- coreFullView lev + = if | lev_tc `hasKey` liftedDataConKey -> assert( null args) $ Just Lifted + | lev_tc `hasKey` unliftedDataConKey -> assert( null args) $ Just Unlifted + | otherwise -> Nothing + | otherwise + = Nothing + + {- ********************************************************************* * * mapType @@ -876,7 +866,7 @@ data TyCoMapper env m -- ^ What to do with coercion holes. -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". - , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) + , tcm_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> m (env, TyCoVar) -- ^ The returned env is used in the extended scope , tcm_tycon :: TyCon -> m TyCon @@ -947,23 +937,24 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar go_mco _ MRefl = return MRefl go_mco env (MCo co) = MCo <$> (go_co env co) - go_co env (Refl ty) = Refl <$> go_ty env ty - go_co env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco - go_co env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 - go_co env (FunCo r cw c1 c2) = mkFunCo r <$> go_co env cw <*> go_co env c1 <*> go_co env c2 - go_co env (CoVarCo cv) = covar env cv - go_co env (HoleCo hole) = cohole env hole - go_co env (UnivCo p r t1 t2) = mkUnivCo <$> go_prov env p <*> pure r - <*> go_ty env t1 <*> go_ty env t2 - go_co env (SymCo co) = mkSymCo <$> go_co env co - go_co env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 - go_co env (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos - go_co env (NthCo r i co) = mkNthCo r i <$> go_co env co - go_co env (LRCo lr co) = mkLRCo lr <$> go_co env co - go_co env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg - go_co env (KindCo co) = mkKindCo <$> go_co env co - go_co env (SubCo co) = mkSubCo <$> go_co env co - go_co env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos + go_co env (Refl ty) = Refl <$> go_ty env ty + go_co env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco + go_co env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 + go_co env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw + <*> go_co env c1 <*> go_co env c2 + go_co env (CoVarCo cv) = covar env cv + go_co env (HoleCo hole) = cohole env hole + go_co env (UnivCo p r t1 t2) = mkUnivCo <$> go_prov env p <*> pure r + <*> go_ty env t1 <*> go_ty env t2 + go_co env (SymCo co) = mkSymCo <$> go_co env co + go_co env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 + go_co env (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos + go_co env (SelCo i co) = mkSelCo i <$> go_co env co + go_co env (LRCo lr co) = mkLRCo lr <$> go_co env co + go_co env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg + go_co env (KindCo co) = mkKindCo <$> go_co env co + go_co env (SubCo co) = mkSubCo <$> go_co env co + go_co env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos go_co env co@(TyConAppCo r tc cos) | isTcTyCon tc = do { tc' <- tycon tc @@ -988,33 +979,32 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar go_prov _ p@(CorePrepProv _) = return p -{- -************************************************************************ +{- ********************************************************************* * * -\subsection{Constructor-specific functions} + TyVarTy * * -************************************************************************ - - ---------------------------------------------------------------------- - TyVarTy - ~~~~~~~ --} +********************************************************************* -} -- | Attempts to obtain the type variable underlying a 'Type', and panics with the -- given message if this is not a type variable type. See also 'getTyVar_maybe' -getTyVar :: String -> Type -> TyVar -getTyVar msg ty = case getTyVar_maybe ty of +getTyVar :: HasDebugCallStack => Type -> TyVar +getTyVar ty = case getTyVar_maybe ty of Just tv -> tv - Nothing -> panic ("getTyVar: " ++ msg) - -isTyVarTy :: Type -> Bool -isTyVarTy ty = isJust (getTyVar_maybe ty) + Nothing -> pprPanic "getTyVar" (ppr ty) -- | Attempts to obtain the type variable underlying a 'Type' getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe = repGetTyVar_maybe . coreFullView +-- | Attempts to obtain the type variable underlying a 'Type', without +-- any expansion +repGetTyVar_maybe :: Type -> Maybe TyVar +repGetTyVar_maybe (TyVarTy tv) = Just tv +repGetTyVar_maybe _ = Nothing + +isTyVarTy :: Type -> Bool +isTyVarTy ty = isJust (getTyVar_maybe ty) + -- | If the type is a tyvar, possibly under a cast, returns it, along -- with the coercion. Thus, the co is :: kind tv ~N kind ty getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) @@ -1023,17 +1013,14 @@ getCastedTyVar_maybe ty = case coreFullView ty of TyVarTy tv -> Just (tv, mkReflCo Nominal (tyVarKind tv)) _ -> Nothing --- | Attempts to obtain the type variable underlying a 'Type', without --- any expansion -repGetTyVar_maybe :: Type -> Maybe TyVar -repGetTyVar_maybe (TyVarTy tv) = Just tv -repGetTyVar_maybe _ = Nothing -{- ---------------------------------------------------------------------- - AppTy - ~~~~~ -We need to be pretty careful with AppTy to make sure we obey the +{- ********************************************************************* +* * + AppTy +* * +********************************************************************* -} + +{- We need to be pretty careful with AppTy to make sure we obey the invariant that a TyConApp is always visibly so. mkAppTy maintains the invariant: use it. @@ -1053,10 +1040,12 @@ up decomposing (Eq Int => Int), and we definitely don't want that. This really only applies to the type checker; in Core, '=>' and '->' are the same, as are 'Constraint' and '*'. But for now I've put -the test in repSplitAppTy_maybe, which applies throughout, because +the test in splitAppTyNoView_maybe, which applies throughout, because the other calls to splitAppTy are in GHC.Core.Unify, which is also used by the type checker (e.g. when matching type-function equations). +We are willing to split (t1 -=> t2) because the argument is still of +kind Type, not Constraint. So the criterion is isVisibleFunArg. -} -- | Applies a type to another, as in e.g. @k a@ @@ -1100,60 +1089,41 @@ splitAppTy_maybe :: Type -> Maybe (Type, Type) -- ^ Attempt to take a type application apart, whether it is a -- function, type constructor, or plain type application. Note -- that type family applications are NEVER unsaturated by this! -splitAppTy_maybe = repSplitAppTy_maybe . coreFullView +splitAppTy_maybe = splitAppTyNoView_maybe . coreFullView + +splitAppTy :: Type -> (Type, Type) +-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', +-- and panics if this is not possible +splitAppTy ty = splitAppTy_maybe ty `orElse` pprPanic "splitAppTy" (ppr ty) ------------- -repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) +splitAppTyNoView_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) -- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that --- any Core view stuff is already done -repSplitAppTy_maybe (FunTy _ w ty1 ty2) - = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - -repSplitAppTy_maybe (AppTy ty1 ty2) +-- any coreView stuff is already done +splitAppTyNoView_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -repSplitAppTy_maybe (TyConApp tc tys) - | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc +splitAppTyNoView_maybe (FunTy af w ty1 ty2) + | Just (tc, tys) <- funTyConAppTy_maybe af w ty1 ty2 + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') + +splitAppTyNoView_maybe (TyConApp tc tys) + | not (tyConMustBeSaturated tc) || tys `lengthExceeds` tyConArity tc , Just (tys', ty') <- snocView tys = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! -repSplitAppTy_maybe _other = Nothing +splitAppTyNoView_maybe _other = Nothing --- This one doesn't break apart (c => t). +tcSplitAppTyNoView_maybe :: Type -> Maybe (Type,Type) +-- ^ Just like splitAppTyNoView_maybe, but does not split (c => t) -- See Note [Decomposing fat arrow c=>t] --- Defined here to avoid module loops between Unify and TcType. -tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) --- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that --- any coreView stuff is already done. Refuses to look through (c => t) -tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = ty1, ft_res = ty2 }) - | VisArg <- af -- See Note [Decomposing fat arrow c=>t] - - -- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, - -- Wrinkle around FunTy - , Just rep1 <- getRuntimeRep_maybe ty1 - , Just rep2 <- getRuntimeRep_maybe ty2 - = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) - - | otherwise +tcSplitAppTyNoView_maybe ty + | FunTy { ft_af = af } <- ty + , not (isVisibleFunArg af) -- See Note [Decomposing fat arrow c=>t] = Nothing - -tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -tcRepSplitAppTy_maybe (TyConApp tc tys) - | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc - , Just (tys', ty') <- snocView tys - = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! -tcRepSplitAppTy_maybe _other = Nothing - -------------- -splitAppTy :: Type -> (Type, Type) --- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', --- and panics if this is not possible -splitAppTy ty = case splitAppTy_maybe ty of - Just pr -> pr - Nothing -> panic "splitAppTy" + | otherwise + = splitAppTyNoView_maybe ty ------------- splitAppTys :: Type -> (Type, [Type]) @@ -1166,44 +1136,42 @@ splitAppTys ty = split ty ty [] split _ (AppTy ty arg) args = split ty ty (arg:args) split _ (TyConApp tc tc_args) args = let -- keep type families saturated - n | mustBeSaturated tc = tyConArity tc - | otherwise = 0 + n | tyConMustBeSaturated tc = tyConArity tc + | otherwise = 0 (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (FunTy _ w ty1 ty2) args + split _ (FunTy af w ty1 ty2) args + | Just (tc,tys) <- funTyConAppTy_maybe af w ty1 ty2 = assert (null args ) - (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 + (TyConApp tc [], tys) - split orig_ty _ args = (orig_ty, args) + split orig_ty _ args = (orig_ty, args) -- | Like 'splitAppTys', but doesn't look through type synonyms -repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) -repSplitAppTys ty = split ty [] +splitAppTysNoView :: HasDebugCallStack => Type -> (Type, [Type]) +splitAppTysNoView ty = split ty [] where split (AppTy ty arg) args = split ty (arg:args) split (TyConApp tc tc_args) args - = let n | mustBeSaturated tc = tyConArity tc - | otherwise = 0 + = let n | tyConMustBeSaturated tc = tyConArity tc + | otherwise = 0 (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) - split (FunTy _ w ty1 ty2) args + split (FunTy af w ty1 ty2) args + | Just (tc, tys) <- funTyConAppTy_maybe af w ty1 ty2 = assert (null args ) - (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 + (TyConApp tc [], tys) split ty args = (ty, args) -{- + +{- ********************************************************************* +* * LitTy - ~~~~~ --} +* * +********************************************************************* -} mkNumLitTy :: Integer -> Type mkNumLitTy n = LitTy (NumTyLit n) @@ -1278,16 +1246,14 @@ pprUserTypeErrorTy ty = _ -> ppr ty +{- ********************************************************************* +* * + FunTy +* * +********************************************************************* -} - -{- ---------------------------------------------------------------------- - FunTy - ~~~~~ - -Note [Representation of function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - +{- Note [Representation of function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Functions (e.g. Int -> Char) can be thought of as being applications of funTyCon (known in Haskell surface syntax as (->)), (note that `RuntimeRep' quantifiers are left inferred) @@ -1315,23 +1281,105 @@ In the compiler we maintain the invariant that all saturated applications of See #11714. -} +----------------------------------------------- +funTyConAppTy_maybe :: FunTyFlag -> Type -> Type -> Type + -> Maybe (TyCon, [Type]) +-- ^ Given the components of a FunTy +-- figure out the corresponding TyConApp. +funTyConAppTy_maybe af mult arg res + | Just arg_rep <- getRuntimeRep_maybe arg + , Just res_rep <- getRuntimeRep_maybe res + , let args | isFUNArg af = [mult, arg_rep, res_rep, arg, res] + | otherwise = [ arg_rep, res_rep, arg, res] + = Just $ (funTyFlagTyCon af, args) + | otherwise + = Nothing + +tyConAppFunTy_maybe :: HasDebugCallStack => TyCon -> [Type] -> Maybe Type +-- ^ Return Just if this TyConApp should be represented as a FunTy +tyConAppFunTy_maybe tc tys + | Just (af, mult, arg, res) <- ty_con_app_fun_maybe manyDataConTy tc tys + = Just (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) + | otherwise = Nothing + +tyConAppFunCo_maybe :: HasDebugCallStack => Role -> TyCon -> [Coercion] + -> Maybe Coercion +-- ^ Return Just if this TyConAppCo should be represented as a FunCo +tyConAppFunCo_maybe r tc cos + | Just (af, mult, arg, res) <- ty_con_app_fun_maybe (mkReflCo r manyDataConTy) tc cos + = Just (mkFunCo1 r af mult arg res) + | otherwise = Nothing + +ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a] + -> Maybe (FunTyFlag, a, a, a) +{-# INLINE ty_con_app_fun_maybe #-} +-- Specialise this function for its two call sites +ty_con_app_fun_maybe many_ty_co tc args + | tc_uniq == fUNTyConKey = fUN_case + | tc_uniq == tcArrowTyConKey = non_FUN_case FTF_T_C + | tc_uniq == ctArrowTyConKey = non_FUN_case FTF_C_T + | tc_uniq == ccArrowTyConKey = non_FUN_case FTF_C_C + | otherwise = Nothing + where + tc_uniq = tyConUnique tc + + fUN_case + | (w:_r1:_r2:a1:a2:rest) <- args + = assertPpr (null rest) (ppr tc <+> ppr args) $ + Just (FTF_T_T, w, a1, a2) + | otherwise = Nothing + + non_FUN_case ftf + | (_r1:_r2:a1:a2:rest) <- args + = assertPpr (null rest) (ppr tc <+> ppr args) $ + Just (ftf, many_ty_co, a1, a2) + | otherwise + = Nothing + +mkFunctionType :: Mult -> Type -> Type -> Type +-- ^ This one works out the FunTyFlag from the argument type +-- See GHC.Types.Var Note [FunTyFlag] +mkFunctionType mult arg_ty res_ty + = FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty + , ft_mult = assertPpr mult_ok (ppr [mult, arg_ty, res_ty]) $ + mult } + where + af = chooseFunTyFlag arg_ty res_ty + mult_ok = isVisibleFunArg af || isManyTy mult + +mkScaledFunctionTys :: [Scaled Type] -> Type -> Type +-- ^ Like mkFunctionType, compute the FunTyFlag from the arguments +mkScaledFunctionTys arg_tys res_ty + = foldr mk res_ty arg_tys + where + mk (Scaled mult arg_ty) res_ty + = mkFunTy (chooseFunTyFlag arg_ty res_ty) + mult arg_ty res_ty + +chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag +-- ^ See GHC.Types.Var Note [FunTyFlag] +chooseFunTyFlag arg_ty res_ty + = mkFunTyFlag (typeTypeOrConstraint arg_ty) (typeTypeOrConstraint res_ty) + splitFunTy :: Type -> (Mult, Type, Type) -- ^ Attempts to extract the multiplicity, argument and result types from a type, -- and panics if that is not possible. See also 'splitFunTy_maybe' -splitFunTy = expectJust "splitFunTy" . splitFunTy_maybe +splitFunTy ty = case splitFunTy_maybe ty of + Just (_af, mult, arg, res) -> (mult,arg,res) + Nothing -> pprPanic "splitFunTy" (ppr ty) {-# INLINE splitFunTy_maybe #-} -splitFunTy_maybe :: Type -> Maybe (Mult, Type, Type) +splitFunTy_maybe :: Type -> Maybe (FunTyFlag, Mult, Type, Type) -- ^ Attempts to extract the multiplicity, argument and result types from a type splitFunTy_maybe ty - | FunTy _ w arg res <- coreFullView ty = Just (w, arg, res) - | otherwise = Nothing + | FunTy af w arg res <- coreFullView ty = Just (af, w, arg, res) + | otherwise = Nothing splitFunTys :: Type -> ([Scaled Type], Type) splitFunTys ty = split [] ty ty where -- common case first - split args _ (FunTy _ w arg res) = split ((Scaled w arg):args) res res + split args _ (FunTy _ w arg res) = split (Scaled w arg : args) res res split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' split args orig_ty _ = (reverse args, orig_ty) @@ -1445,7 +1493,6 @@ applyTysX tvs body_ty arg_tys (arg_tys_prefix, arg_tys_rest) = splitAtList tvs arg_tys - {- Note [Care with kind instantiation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -1471,12 +1518,15 @@ We have So again we must instantiate. The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. - ---------------------------------------------------------------------- - TyConApp - ~~~~~~~~ -} + +{- ********************************************************************* +* * + TyConApp +* * +********************************************************************* -} + -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. @@ -1484,110 +1534,85 @@ The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. -- | Retrieve the tycon heading this type, if there is one. Does /not/ -- look through synonyms. tyConAppTyConPicky_maybe :: Type -> Maybe TyCon -tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc -tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon -tyConAppTyConPicky_maybe _ = Nothing +tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc +tyConAppTyConPicky_maybe (FunTy { ft_af = af }) = Just (funTyFlagTyCon af) +tyConAppTyConPicky_maybe _ = Nothing -- | The same as @fst . splitTyConApp@ +-- We can short-cut the FunTy case {-# INLINE tyConAppTyCon_maybe #-} tyConAppTyCon_maybe :: Type -> Maybe TyCon tyConAppTyCon_maybe ty = case coreFullView ty of - TyConApp tc _ -> Just tc - FunTy {} -> Just funTyCon - _ -> Nothing + TyConApp tc _ -> Just tc + FunTy { ft_af = af } -> Just (funTyFlagTyCon af) + _ -> Nothing tyConAppTyCon :: HasDebugCallStack => Type -> TyCon tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) -- | The same as @snd . splitTyConApp@ tyConAppArgs_maybe :: Type -> Maybe [Type] -tyConAppArgs_maybe ty = case coreFullView ty of - TyConApp _ tys -> Just tys - FunTy _ w arg res - | Just rep1 <- getRuntimeRep_maybe arg - , Just rep2 <- getRuntimeRep_maybe res - -> Just [w, rep1, rep2, arg, res] - _ -> Nothing +tyConAppArgs_maybe ty = case splitTyConApp_maybe ty of + Just (_, tys) -> Just tys + Nothing -> Nothing tyConAppArgs :: HasCallStack => Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) -tyConAppArgN :: Int -> Type -> Type --- Executing Nth -tyConAppArgN n ty - = case tyConAppArgs_maybe ty of - Just tys -> tys `getNth` n - Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) - -- | Attempts to tease a type apart into a type constructor and the application -- of a number of arguments to that constructor. Panics if that is not possible. -- See also 'splitTyConApp_maybe' splitTyConApp :: Type -> (TyCon, [Type]) -splitTyConApp ty = case splitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "splitTyConApp" (ppr ty) +splitTyConApp ty = splitTyConApp_maybe ty `orElse` pprPanic "splitTyConApp" (ppr ty) -- | Attempts to tease a type apart into a type constructor and the application -- of a number of arguments to that constructor splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -splitTyConApp_maybe = repSplitTyConApp_maybe . coreFullView - --- | Split a type constructor application into its type constructor and --- applied types. Note that this may fail in the case of a 'FunTy' with an --- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind --- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your --- type before using this function. --- --- This does *not* split types headed with (=>), as that's not a TyCon in the --- type-checker. --- --- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. -tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) --- Defined here to avoid module loops between Unify and TcType. -tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' - | otherwise = tcRepSplitTyConApp_maybe ty - -------------------- -repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) --- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This --- assumes the synonyms have already been dealt with. -repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -repSplitTyConApp_maybe (FunTy _ w arg res) - -- NB: we're in Core, so no check for VisArg - = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) - where - arg_rep = getRuntimeRep arg - res_rep = getRuntimeRep res -repSplitTyConApp_maybe _ = Nothing - -tcRepSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) --- ^ Like 'tcSplitTyConApp_maybe', but doesn't look through synonyms. This --- assumes the synonyms have already been dealt with. --- --- Moreover, for a FunTy, it only succeeds if the argument types --- have enough info to extract the runtime-rep arguments that --- the funTyCon requires. This will usually be true; --- but may be temporarily false during canonicalization: +splitTyConApp_maybe ty = splitTyConAppNoView_maybe (coreFullView ty) + +splitTyConAppNoView_maybe :: Type -> Maybe (TyCon, [Type]) +-- Same as splitTyConApp_maybe but without looking through synonyms +splitTyConAppNoView_maybe ty + = case ty of + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + -> funTyConAppTy_maybe af w arg res + TyConApp tc tys -> Just (tc, tys) + _ -> Nothing + +-- | tcSplitTyConApp_maybe splits a type constructor application into +-- its type constructor and applied types. +-- +-- Differs from splitTyConApp_maybe in that it does *not* split types +-- headed with (=>), as that's not a TyCon in the type-checker. +-- +-- Note that this may fail (in funTyConAppTy_maybe) in the case +-- of a 'FunTy' with an argument of unknown kind 'FunTy' +-- (e.g. `FunTy (a :: k) Int`, since the kind of @a@ isn't of +-- the form `TYPE rep`. This isn't usually a problem but may +-- be temporarily the cas during canonicalization: -- see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical -- and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, -- Wrinkle around FunTy -tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcRepSplitTyConApp_maybe (FunTy VisArg w arg res) - -- NB: VisArg. See Note [Decomposing fat arrow c=>t] - | Just arg_rep <- getRuntimeRep_maybe arg - , Just res_rep <- getRuntimeRep_maybe res - = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) -tcRepSplitTyConApp_maybe _ = Nothing - -------------------- --- | Attempts to tease a list type apart and gives the type of the elements if --- successful (looks through type synonyms) -splitListTyConApp_maybe :: Type -> Maybe Type -splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of - Just (tc,[e]) | tc == listTyCon -> Just e - _other -> Nothing - +-- +-- Consequently, you may need to zonk your type before +-- using this function. +tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) +-- Defined here to avoid module loops between Unify and TcType. +tcSplitTyConApp_maybe ty + = case coreFullView ty of + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + | isVisibleFunArg af -- Visible args only + -- See Note [Decomposing fat arrow c=>t] + -> funTyConAppTy_maybe af w arg res + TyConApp tc tys -> Just (tc, tys) + _ -> Nothing + +tcSplitTyConApp :: Type -> (TyCon, [Type]) +tcSplitTyConApp ty + = tcSplitTyConApp_maybe ty `orElse` pprPanic "tcSplitTyConApp" (ppr ty) + +--------------------------- newTyConInstRhs :: TyCon -> [Type] -> Type -- ^ Unwrap one 'layer' of newtype on a type constructor and its -- arguments, using an eta-reduced version of the @newtype@ if possible. @@ -1598,12 +1623,12 @@ newTyConInstRhs tycon tys where (tvs, rhs) = newTyConEtadRhs tycon -{- ---------------------------------------------------------------------- - CastTy - ~~~~~~ -A casted type has its *kind* casted into something new. --} + +{- ********************************************************************* +* * + CastTy +* * +********************************************************************* -} splitCastTy_maybe :: Type -> Maybe (Type, Coercion) splitCastTy_maybe ty @@ -1671,207 +1696,13 @@ The solution is easy: just use `coreView` when establishing (EQ3) and (EQ4) in `mk_cast_ty`. -} -tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] --- Return the tyConBinders in TyCoBinder form -tyConBindersTyCoBinders = map to_tyb - where - to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) - to_tyb (Bndr tv (AnonTCB af)) = Anon af (tymult (varType tv)) - --- | (mkTyConTy tc) returns (TyConApp tc []) --- but arranges to share that TyConApp among all calls --- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = tyConNullaryTy tycon - --- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to --- its arguments. Applies its arguments to the constructor from left to right. -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon [] - = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon - mkTyConTy tycon - -mkTyConApp tycon tys@(ty1:rest) - | key == funTyConKey - = case tys of - [w, _rep1,_rep2,arg,res] -> FunTy { ft_af = VisArg, ft_mult = w - , ft_arg = arg, ft_res = res } - _ -> bale_out - - -- See Note [Using synonyms to compress types] - | key == tYPETyConKey - = assert (null rest) $ --- mkTYPEapp_maybe ty1 `orElse` bale_out - case mkTYPEapp_maybe ty1 of - Just ty -> ty -- pprTrace "mkTYPEapp:yes" (ppr ty) ty - Nothing -> bale_out -- pprTrace "mkTYPEapp:no" (ppr bale_out) bale_out - - -- See Note [Using synonyms to compress types] - | key == boxedRepDataConTyConKey - = assert (null rest) $ --- mkBoxedRepApp_maybe ty1 `orElse` bale_out - case mkBoxedRepApp_maybe ty1 of - Just ty -> ty -- pprTrace "mkBoxedRepApp:yes" (ppr ty) ty - Nothing -> bale_out -- pprTrace "mkBoxedRepApp:no" (ppr bale_out) bale_out - - | key == tupleRepDataConTyConKey - = case mkTupleRepApp_maybe ty1 of - Just ty -> ty -- pprTrace "mkTupleRepApp:yes" (ppr ty) ty - Nothing -> bale_out -- pprTrace "mkTupleRepApp:no" (ppr bale_out) bale_out - - -- The catch-all case - | otherwise - = bale_out - where - key = tyConUnique tycon - bale_out = TyConApp tycon tys - -mkTYPEapp :: RuntimeRepType -> Type -mkTYPEapp rr - = case mkTYPEapp_maybe rr of - Just ty -> ty - Nothing -> TyConApp tYPETyCon [rr] - -mkTYPEapp_maybe :: RuntimeRepType -> Maybe Type --- ^ Given a @RuntimeRep@, applies @TYPE@ to it. --- On the fly it rewrites --- TYPE LiftedRep --> liftedTypeKind (a synonym) --- TYPE UnliftedRep --> unliftedTypeKind (ditto) --- TYPE ZeroBitRep --> zeroBitTypeKind (ditto) --- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted) --- because those inner types should already have been rewritten --- to LiftedRep and UnliftedRep respectively, by mkTyConApp --- --- see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. --- See Note [Using synonyms to compress types] in GHC.Core.Type -{-# NOINLINE mkTYPEapp_maybe #-} -mkTYPEapp_maybe (TyConApp tc args) - | key == liftedRepTyConKey = assert (null args) $ Just liftedTypeKind -- TYPE LiftedRep - | key == unliftedRepTyConKey = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep - | key == zeroBitRepTyConKey = assert (null args) $ Just zeroBitTypeKind -- TYPE ZeroBitRep - where - key = tyConUnique tc -mkTYPEapp_maybe _ = Nothing - -mkBoxedRepApp_maybe :: Type -> Maybe Type --- ^ Given a `Levity`, apply `BoxedRep` to it --- On the fly, rewrite --- BoxedRep Lifted --> liftedRepTy (a synonym) --- BoxedRep Unlifted --> unliftedRepTy (ditto) --- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. --- See Note [Using synonyms to compress types] in GHC.Core.Type -{-# NOINLINE mkBoxedRepApp_maybe #-} -mkBoxedRepApp_maybe (TyConApp tc args) - | key == liftedDataConKey = assert (null args) $ Just liftedRepTy -- BoxedRep Lifted - | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy -- BoxedRep Unlifted - where - key = tyConUnique tc -mkBoxedRepApp_maybe _ = Nothing - -mkTupleRepApp_maybe :: Type -> Maybe Type --- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it --- On the fly, rewrite --- TupleRep [] -> zeroBitRepTy (a synonym) --- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. --- See Note [Using synonyms to compress types] in GHC.Core.Type -{-# NOINLINE mkTupleRepApp_maybe #-} -mkTupleRepApp_maybe (TyConApp tc args) - | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy -- ZeroBitRep - where - key = tyConUnique tc -mkTupleRepApp_maybe _ = Nothing - -{- Note [Using synonyms to compress types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Was: Prefer Type over TYPE (BoxedRep Lifted)] - -The Core of nearly any program will have numerous occurrences of the Types - - TyConApp BoxedRep [TyConApp Lifted []] -- Synonym LiftedRep - TyConApp BoxedRep [TyConApp Unlifted []] -- Synonym UnliftedREp - TyConApp TYPE [TyConApp LiftedRep []] -- Synonym Type - TyConApp TYPE [TyConApp UnliftedRep []] -- Synonym UnliftedType - -While investigating #17292 we found that these constituted a majority -of all TyConApp constructors on the heap: - - (From a sample of 100000 TyConApp closures) - 0x45f3523 - 28732 - `Type` - 0x420b840702 - 9629 - generic type constructors - 0x42055b7e46 - 9596 - 0x420559b582 - 9511 - 0x420bb15a1e - 9509 - 0x420b86c6ba - 9501 - 0x42055bac1e - 9496 - 0x45e68fd - 538 - `TYPE ...` - -Consequently, we try hard to ensure that operations on such types are -efficient. Specifically, we strive to - - a. Avoid heap allocation of such types; use a single static TyConApp - b. Use a small (shallow in the tree-depth sense) representation - for such types - -Goal (b) is particularly useful as it makes traversals (e.g. free variable -traversal, substitution, and comparison) more efficient. -Comparison in particular takes special advantage of nullary type synonym -applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing -nullary type synonyms] in "GHC.Core.Type". - -To accomplish these we use a number of tricks, implemented by mkTyConApp. - - 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]), - we prefer a statically-allocated (TyConApp LiftedRep []) - where `LiftedRep` is a type synonym: - type LiftedRep = BoxedRep Lifted - Similarly for UnliftedRep - - 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []]) - we prefer the statically-allocated (TyConApp Type []) - where `Type` is a type synonym - type Type = TYPE LiftedRep - Similarly for UnliftedType - -These serve goal (b) since there are no applied type arguments to traverse, -e.g., during comparison. - - 3. We have a single, statically allocated top-level binding to - represent `TyConApp GHC.Types.Type []` (namely - 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't - need to allocate such types (goal (a)). See functions - mkTYPEapp and mkBoxedRepApp - - 4. We use the sharing mechanism described in Note [Sharing nullary TyConApps] - in GHC.Core.TyCon to ensure that we never need to allocate such - nullary applications (goal (a)). - -See #17958, #20541 - -Note [Care using synonyms to compress types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Using a synonym to compress a types has a tricky wrinkle. Consider -coreView applied to (TyConApp LiftedRep []) - -* coreView expands the LiftedRep synonym: - type LiftedRep = BoxedRep Lifted - -* Danger: we might apply the empty substitution to the RHS of the - synonym. And substTy calls mkTyConApp BoxedRep [Lifted]. And - mkTyConApp compresses that back to LiftedRep. Loop! - -* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary - type synonyms. That's more efficient anyway. --} - - - -{- --------------------------------------------------------------------- - CoercionTy - ~~~~~~~~~~ -CoercionTy allows us to inject coercions into types. A CoercionTy -should appear only in the right-hand side of an application. --} +{- ********************************************************************* +* * + CoercionTy + CoercionTy allows us to inject coercions into types. A CoercionTy + should appear only in the right-hand side of an application. +* * +********************************************************************* -} mkCoercionTy :: Coercion -> Type mkCoercionTy = CoercionTy @@ -1888,30 +1719,19 @@ stripCoercionTy :: Type -> Coercion stripCoercionTy (CoercionTy co) = co stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) -{- ---------------------------------------------------------------------- - SynTy - ~~~~~ - -Notes on type synonyms -~~~~~~~~~~~~~~~~~~~~~~ -The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try -to return type synonyms wherever possible. Thus - - type Foo a = a -> a - -we want - splitFunTys (a -> Foo a) = ([a], Foo a) -not ([a], a -> a) - -The reason is that we then get better (shorter) type signatures in -interfaces. Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind. +{- ********************************************************************* +* * + ForAllTy +* * +********************************************************************* -} ---------------------------------------------------------------------- - ForAllTy - ~~~~~~~~ --} +tyConBindersPiTyBinders :: [TyConBinder] -> [PiTyBinder] +-- Return the tyConBinders in PiTyBinder form +tyConBindersPiTyBinders = map to_tyb + where + to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) + to_tyb (Bndr tv (AnonTCB af)) = Anon (tymult (varType tv)) af -- | Make a dependent forall over an 'Inferred' variable mkTyCoInvForAllTy :: TyCoVar -> Type -> Type @@ -1955,7 +1775,7 @@ mkVisForAllTys tvs = assert (all isTyVar tvs ) mkForAllTys [ Bndr tv Required | tv <- tvs ] -- | Given a list of type-level vars and the free vars of a result kind, --- makes TyCoBinders, preferring anonymous binders +-- makes PiTyBinders, preferring anonymous binders -- if the variable is, in fact, not dependent. -- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) -- We want (k:*) Named, (b:k) Anon, (c:k) Anon @@ -1973,12 +1793,21 @@ mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars) = ( Bndr v (NamedTCB Required) : binders , fvs `delVarSet` v `unionVarSet` kind_vars ) | otherwise - = ( Bndr v (AnonTCB VisArg) : binders + = ( Bndr v (AnonTCB visArgTypeLike) : binders , fvs `unionVarSet` kind_vars ) where (binders, fvs) = go vs kind_vars = tyCoVarsOfType $ tyVarKind v +-- | Take a ForAllTy apart, returning the binders and result type +splitForAllForAllTyBinders :: Type -> ([ForAllTyBinder], Type) +splitForAllForAllTyBinders ty = split ty ty [] + where + split _ (ForAllTy b res) bs = split res res (b:bs) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) +{-# INLINE splitForAllForAllTyBinders #-} + -- | Take a ForAllTy apart, returning the list of tycovars and the result type. -- This always succeeds, even if it returns only an empty list. Note that the -- result type returned may have free variables that were bound by a forall. @@ -1989,44 +1818,34 @@ splitForAllTyCoVars ty = split ty ty [] split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split orig_ty _ tvs = (reverse tvs, orig_ty) --- | Splits the longest initial sequence of 'ForAllTy's that satisfy --- @argf_pred@, returning the binders transformed by @argf_pred@ -splitSomeForAllTyCoVarBndrs :: (ArgFlag -> Maybe af) -> Type -> ([VarBndr TyCoVar af], Type) -splitSomeForAllTyCoVarBndrs argf_pred ty = split ty ty [] +-- | Like 'splitForAllTyCoVars', but split only for tyvars. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTyVars :: Type -> ([TyVar], Type) +splitForAllTyVars ty = split ty ty [] where - split _ (ForAllTy (Bndr tcv argf) ty) tvs - | Just argf' <- argf_pred argf = split ty ty (Bndr tcv argf' : tvs) - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. Furthermore, each returned tyvar is annotated with '()'. -splitForAllReqTVBinders :: Type -> ([ReqTVBinder], Type) -splitForAllReqTVBinders ty = splitSomeForAllTyCoVarBndrs argf_pred ty +splitForAllReqTyBinders :: Type -> ([ReqTyBinder], Type) +splitForAllReqTyBinders ty = split ty ty [] where - argf_pred :: ArgFlag -> Maybe () - argf_pred Required = Just () - argf_pred (Invisible {}) = Nothing + split _ (ForAllTy (Bndr tv Required) ty) tvs = split ty ty (Bndr tv ():tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Invisible' type -- variable binders. Furthermore, each returned tyvar is annotated with its -- 'Specificity'. -splitForAllInvisTVBinders :: Type -> ([InvisTVBinder], Type) -splitForAllInvisTVBinders ty = splitSomeForAllTyCoVarBndrs argf_pred ty - where - argf_pred :: ArgFlag -> Maybe Specificity - argf_pred Required = Nothing - argf_pred (Invisible spec) = Just spec - --- | Like 'splitForAllTyCoVars', but split only for tyvars. --- This always succeeds, even if it returns only an empty list. Note that the --- result type returned may have free variables that were bound by a forall. -splitForAllTyVars :: Type -> ([TyVar], Type) -splitForAllTyVars ty = split ty ty [] +splitForAllInvisTyBinders :: Type -> ([InvisTyBinder], Type) +splitForAllInvisTyBinders ty = split ty ty [] where - split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy (Bndr tv (Invisible spec)) ty) tvs = split ty ty (Bndr tv spec:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Checks whether this is a proper forall (with a named binder) isForAllTy :: Type -> Bool @@ -2087,7 +1906,7 @@ splitForAllTyCoVar_maybe ty | otherwise = Nothing -- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a tyvar binder. -splitForAllTyVar_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type) splitForAllTyVar_maybe ty | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty , isTyVar tv @@ -2096,7 +1915,7 @@ splitForAllTyVar_maybe ty | otherwise = Nothing -- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder. -splitForAllCoVar_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllCoVar_maybe :: Type -> Maybe (CoVar, Type) splitForAllCoVar_maybe ty | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty , isCoVar tv @@ -2107,27 +1926,27 @@ splitForAllCoVar_maybe ty -- | Attempts to take a forall type apart; works with proper foralls and -- functions {-# INLINE splitPiTy_maybe #-} -- callers will immediately deconstruct -splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) +splitPiTy_maybe :: Type -> Maybe (PiTyBinder, Type) splitPiTy_maybe ty = case coreFullView ty of ForAllTy bndr ty -> Just (Named bndr, ty) FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} - -> Just (Anon af (mkScaled w arg), res) + -> Just (Anon (mkScaled w arg) af, res) _ -> Nothing -- | Takes a forall type apart, or panics -splitPiTy :: Type -> (TyCoBinder, Type) +splitPiTy :: Type -> (PiTyBinder, Type) splitPiTy ty | Just answer <- splitPiTy_maybe ty = answer | otherwise = pprPanic "splitPiTy" (ppr ty) --- | Split off all TyCoBinders to a type, splitting both proper foralls +-- | Split off all PiTyBinders to a type, splitting both proper foralls -- and functions -splitPiTys :: Type -> ([TyCoBinder], Type) +splitPiTys :: Type -> ([PiTyBinder], Type) splitPiTys ty = split ty ty [] where split _ (ForAllTy b res) bs = split res res (Named b : bs) split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs - = split res res (Anon af (Scaled w arg) : bs) + = split res res (Anon (Scaled w arg) af : bs) split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split orig_ty _ bs = (reverse bs, orig_ty) @@ -2139,10 +1958,11 @@ splitPiTys ty = split ty ty [] -- @ -- newtype Identity a = I a -- --- getRuntimeArgTys (Int -> Bool -> Double) == [(Int, VisArg), (Bool, VisArg)] --- getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, VisArg), (Bool, VisArg)] --- getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, VisArg), (Bool, VisArg)] --- getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool) == [(Show a, InvisArg), (Identity a, VisArg),(a, VisArg),(Int, VisArg)] +-- getRuntimeArgTys (Int -> Bool -> Double) == [(Int, FTF_T_T), (Bool, FTF_T_T)] +-- getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, FTF_T_T), (Bool, FTF_T_T)] +-- getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, FTF_T_T), (Bool, FTF_T_T)] +-- getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool) +-- == [(Show a, FTF_C_T), (Identity a, FTF_T_T),(a, FTF_T_T),(Int, FTF_T_T)] -- @ -- -- Note that, in the last case, the returned types might mention an out-of-scope @@ -2153,12 +1973,12 @@ splitPiTys ty = split ty ty [] -- -- @ -- newtype N a = MkN (a -> N a) --- getRuntimeArgTys (N a) == repeat (a, VisArg) +-- getRuntimeArgTys (N a) == repeat (a, FTF_T_T) -- @ -getRuntimeArgTys :: Type -> [(Scaled Type, AnonArgFlag)] +getRuntimeArgTys :: Type -> [(Scaled Type, FunTyFlag)] getRuntimeArgTys = go where - go :: Type -> [(Scaled Type, AnonArgFlag)] + go :: Type -> [(Scaled Type, FunTyFlag)] go (ForAllTy _ res) = go res go (FunTy { ft_mult = w, ft_arg = arg, ft_res = res, ft_af = af }) @@ -2171,16 +1991,6 @@ getRuntimeArgTys = go | otherwise = [] --- | Like 'splitPiTys' but split off only /named/ binders --- and returns 'TyCoVarBinder's rather than 'TyCoBinder's -splitForAllTyCoVarBinders :: Type -> ([TyCoVarBinder], Type) -splitForAllTyCoVarBinders ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs = split res res (b:bs) - split orig_ty _ bs = (reverse bs, orig_ty) -{-# INLINE splitForAllTyCoVarBinders #-} - invisibleTyBndrCount :: Type -> Int -- Returns the number of leading invisible forall'd binders in the type -- Includes invisible predicate arguments; e.g. for @@ -2190,21 +2000,21 @@ invisibleTyBndrCount ty = length (fst (splitInvisPiTys ty)) -- | Like 'splitPiTys', but returns only *invisible* binders, including constraints. -- Stops at the first visible binder. -splitInvisPiTys :: Type -> ([TyCoBinder], Type) +splitInvisPiTys :: Type -> ([PiTyBinder], Type) splitInvisPiTys ty = split ty ty [] where split _ (ForAllTy b res) bs | Bndr _ vis <- b - , isInvisibleArgFlag vis = split res res (Named b : bs) - split _ (FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res }) bs - = split res res (Anon InvisArg (mkScaled mult arg) : bs) + , isInvisibleForAllTyFlag vis = split res res (Named b : bs) + split _ (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) bs + | isInvisibleFunArg af = split res res (Anon (mkScaled mult arg) af : bs) split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split orig_ty _ bs = (reverse bs, orig_ty) -splitInvisPiTysN :: Int -> Type -> ([TyCoBinder], Type) +splitInvisPiTysN :: Int -> Type -> ([PiTyBinder], Type) -- ^ Same as 'splitInvisPiTys', but stop when --- - you have found @n@ 'TyCoBinder's, +-- - you have found @n@ 'PiTyBinder's, -- - or you run out of invisible binders splitInvisPiTysN n ty = split n ty ty [] where @@ -2213,10 +2023,10 @@ splitInvisPiTysN n ty = split n ty ty [] | Just ty' <- coreView ty = split n orig_ty ty' bs | ForAllTy b res <- ty , Bndr _ vis <- b - , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) - | FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty - = split (n-1) res res (Anon InvisArg (Scaled mult arg) : bs) - | otherwise = (reverse bs, orig_ty) + , isInvisibleForAllTyFlag vis = split (n-1) res res (Named b : bs) + | FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty + , isInvisibleFunArg af = split (n-1) res res (Anon (Scaled mult arg) af : bs) + | otherwise = (reverse bs, orig_ty) -- | Given a 'TyCon' and a list of argument types, filter out any invisible -- (i.e., 'Inferred' or 'Specified') arguments. @@ -2227,7 +2037,7 @@ filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys -- arguments. filterOutInferredTypes :: TyCon -> [Type] -> [Type] filterOutInferredTypes tc tys = - filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys + filterByList (map (/= Inferred) $ tyConForAllTyFlags tc tys) tys -- | Given a 'TyCon' and a list of argument types, partition the arguments -- into: @@ -2237,15 +2047,15 @@ filterOutInferredTypes tc tys = -- 2. 'Required' (i.e., visible) arguments partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) partitionInvisibleTypes tc tys = - partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys + partitionByList (map isInvisibleForAllTyFlag $ tyConForAllTyFlags tc tys) tys -- | Given a list of things paired with their visibilities, partition the -- things into (invisible things, visible things). -partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a]) +partitionInvisibles :: [(a, ForAllTyFlag)] -> ([a], [a]) partitionInvisibles = partitionWith pick_invis where - pick_invis :: (a, ArgFlag) -> Either a a - pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing + pick_invis :: (a, ForAllTyFlag) -> Either a a + pick_invis (thing, vis) | isInvisibleForAllTyFlag vis = Left thing | otherwise = Right thing -- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is @@ -2255,7 +2065,7 @@ partitionInvisibles = partitionWith pick_invis -- Wrinkle: consider the following scenario: -- -- > T :: forall k. k -> k --- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] +-- > tyConForAllTyFlags T [forall m. m -> m -> m, S, R, Q] -- -- After substituting, we get -- @@ -2263,8 +2073,8 @@ partitionInvisibles = partitionWith pick_invis -- -- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, -- and @Q@ is visible. -tyConArgFlags :: TyCon -> [Type] -> [ArgFlag] -tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) +tyConForAllTyFlags :: TyCon -> [Type] -> [ForAllTyFlag] +tyConForAllTyFlags tc = fun_kind_arg_flags (tyConKind tc) -- | Given a 'Type' and a list of argument types to which the 'Type' is -- applied, determine each argument's visibility @@ -2273,16 +2083,16 @@ tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) -- Most of the time, the arguments will be 'Required', but not always. Consider -- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is -- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely --- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy, +-- this sort of higher-rank situation in which 'appTyForAllTyFlags' comes in handy, -- since @f Type Bool@ would be represented in Core using 'AppTy's. -- (See also #15792). -appTyArgFlags :: Type -> [Type] -> [ArgFlag] -appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) +appTyForAllTyFlags :: Type -> [Type] -> [ForAllTyFlag] +appTyForAllTyFlags ty = fun_kind_arg_flags (typeKind ty) -- | Given a function kind and a list of argument types (where each argument's -- kind aligns with the corresponding position in the argument kind), determine -- each argument's visibility ('Inferred', 'Specified', or 'Required'). -fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] +fun_kind_arg_flags :: Kind -> [Type] -> [ForAllTyFlag] fun_kind_arg_flags = go emptySubst where go subst ki arg_tys @@ -2299,16 +2109,15 @@ fun_kind_arg_flags = go emptySubst -- -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type -- - -- Here, we want to get the following ArgFlags: + -- Here, we want to get the following ForAllTyFlags: -- -- [Inferred, Specified, Required, Required, Specified, Required] -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) = argf : go subst res_ki arg_tys where - argf = case af of - VisArg -> Required - InvisArg -> Inferred + argf | isVisibleFunArg af = Required + | otherwise = Inferred go _ _ arg_tys = map (const Required) arg_tys -- something is ill-kinded. But this can happen -- when printing errors. Assume everything is Required. @@ -2320,9 +2129,9 @@ isTauTy (TyVarTy _) = True isTauTy (LitTy {}) = True isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy af w a b) = case af of - InvisArg -> False -- e.g., Eq a => b - VisArg -> isTauTy w && isTauTy a && isTauTy b -- e.g., a -> b +isTauTy (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) + | isInvisibleFunArg af = False -- e.g., Eq a => b + | otherwise = isTauTy w && isTauTy a && isTauTy b -- e.g., a -> b isTauTy (ForAllTy {}) = False isTauTy (CastTy ty _) = isTauTy ty isTauTy (CoercionTy _) = False -- Not sure about this @@ -2342,43 +2151,6 @@ isAtomicTy ty | isLiftedTypeKind ty = True isAtomicTy _ = False {- -%************************************************************************ -%* * - TyCoBinders -%* * -%************************************************************************ --} - --- | Make an anonymous binder -mkAnonBinder :: AnonArgFlag -> Scaled Type -> TyCoBinder -mkAnonBinder = Anon - --- | Does this binder bind a variable that is /not/ erased? Returns --- 'True' for anonymous binders. -isAnonTyCoBinder :: TyCoBinder -> Bool -isAnonTyCoBinder (Named {}) = False -isAnonTyCoBinder (Anon {}) = True - -tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar -tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv -tyCoBinderVar_maybe _ = Nothing - -tyCoBinderType :: TyCoBinder -> Type -tyCoBinderType (Named tvb) = binderType tvb -tyCoBinderType (Anon _ ty) = scaledThing ty - -tyBinderType :: TyBinder -> Type -tyBinderType (Named (Bndr tv _)) - = assert (isTyVar tv ) - tyVarKind tv -tyBinderType (Anon _ ty) = scaledThing ty - --- | Extract a relevant type, if there is one. -binderRelevantType_maybe :: TyCoBinder -> Maybe Type -binderRelevantType_maybe (Named {}) = Nothing -binderRelevantType_maybe (Anon _ ty) = Just (scaledThing ty) - -{- ************************************************************************ * * \subsection{Type families} @@ -2631,7 +2403,7 @@ isValidJoinPointType arity ty = tvs `disjointVarSet` tyCoVarsOfType ty | Just (t, ty') <- splitForAllTyCoVar_maybe ty = valid_under (tvs `extendVarSet` t) (arity-1) ty' - | Just (_, _, res_ty) <- splitFunTy_maybe ty + | Just (_, _, _, res_ty) <- splitFunTy_maybe ty = valid_under tvs (arity-1) res_ty | otherwise = False @@ -2693,327 +2465,56 @@ seqTypes (ty:tys) = seqType ty `seq` seqTypes tys {- ************************************************************************ * * - Comparison for types - (We don't use instances so that we know where it happens) -* * -************************************************************************ - -Note [Equality on AppTys] -~~~~~~~~~~~~~~~~~~~~~~~~~ -In our cast-ignoring equality, we want to say that the following two -are equal: - - (Maybe |> co) (Int |> co') ~? Maybe Int - -But the left is an AppTy while the right is a TyConApp. The solution is -to use repSplitAppTy_maybe to break up the TyConApp into its pieces and -then continue. Easy to do, but also easy to forget to do. - -Note [Comparing nullary type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the task of testing equality between two 'Type's of the form - - TyConApp tc [] - -where @tc@ is a type synonym. A naive way to perform this comparison these -would first expand the synonym and then compare the resulting expansions. - -However, this is obviously wasteful and the RHS of @tc@ may be large; it is -much better to rather compare the TyCons directly. Consequently, before -expanding type synonyms in type comparisons we first look for a nullary -TyConApp and simply compare the TyCons if we find one. Of course, if we find -that the TyCons are *not* equal then we still need to perform the expansion as -their RHSs may still be equal. - -We perform this optimisation in a number of places: - - * GHC.Core.Types.eqType - * GHC.Core.Types.nonDetCmpType - * GHC.Core.Unify.unify_ty - * TcCanonical.can_eq_nc' - * TcUnify.uType - -This optimisation is especially helpful for the ubiquitous GHC.Types.Type, -since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications -whenever possible. See Note [Using synonyms to compress types] in -GHC.Core.Type for details. - --} - -eqType :: Type -> Type -> Bool --- ^ Type equality on source types. Does not look through @newtypes@, --- 'PredType's or type families, but it does look through type synonyms. --- This first checks that the kinds of the types are equal and then --- checks whether the types are equal, ignoring casts and coercions. --- (The kind check is a recursive call, but since all kinds have type --- @Type@, there is no need to check the types of kinds.) --- See also Note [Non-trivial definitional equality] in "GHC.Core.TyCo.Rep". -eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 - -- It's OK to use nonDetCmpType here and eqType is deterministic, - -- nonDetCmpType does equality deterministically - --- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. -eqTypeX :: RnEnv2 -> Type -> Type -> Bool -eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 - -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, - -- nonDetCmpTypeX does equality deterministically - --- | Type equality on lists of types, looking through type synonyms --- but not newtypes. -eqTypes :: [Type] -> [Type] -> Bool -eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 - -- It's OK to use nonDetCmpType here and eqTypes is deterministic, - -- nonDetCmpTypes does equality deterministically - -eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 --- Check that the var lists are the same length --- and have matching kinds; if so, extend the RnEnv2 --- Returns Nothing if they don't match -eqVarBndrs env [] [] - = Just env -eqVarBndrs env (tv1:tvs1) (tv2:tvs2) - | eqTypeX env (varType tv1) (varType tv2) - = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 -eqVarBndrs _ _ _= Nothing - --- Now here comes the real worker - -{- -Note [nonDetCmpType nondeterminism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX -uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for -ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, -comparing type variables is nondeterministic, note the call to nonDetCmpVar in -nonDetCmpTypeX. -See Note [Unique Determinism] for more details. - -Note [Type comparisons using object pointer comparisons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Quite often we substitute the type from a definition site into -occurances without a change. This means for code like: - \x -> (x,x,x) -The type of every `x` will often be represented by a single object -in the heap. We can take advantage of this by shortcutting the equality -check if two types are represented by the same pointer under the hood. -In some cases this reduces compiler allocations by ~2%. - -Note [Computing equality on types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several places within GHC that depend on the precise choice of -definitional equality used. If we change that definition, all these places -must be updated. This Note merely serves as a place for all these places -to refer to, so searching for references to this Note will find every place -that needs to be updated. - -See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. - --} - -nonDetCmpType :: Type -> Type -> Ordering -nonDetCmpType !t1 !t2 - -- See Note [Type comparisons using object pointer comparisons] - | 1# <- reallyUnsafePtrEquality# t1 t2 - = EQ -nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 - = EQ -nonDetCmpType t1 t2 = - -- we know k1 and k2 have the same kind, because they both have kind *. - nonDetCmpTypeX rn_env t1 t2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) -{-# INLINE nonDetCmpType #-} - -nonDetCmpTypes :: [Type] -> [Type] -> Ordering -nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) - --- | An ordering relation between two 'Type's (known below as @t1 :: k1@ --- and @t2 :: k2@) -data TypeOrdering = TLT -- ^ @t1 < t2@ - | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, - -- therefore we can conclude @k1 ~ k2@ - | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so - -- they may differ in kind. - | TGT -- ^ @t1 > t2@ - deriving (Eq, Ord, Enum, Bounded) - -nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse - -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep - -- See Note [Computing equality on types] -nonDetCmpTypeX env orig_t1 orig_t2 = - case go env orig_t1 orig_t2 of - -- If there are casts then we also need to do a comparison of the kinds of - -- the types being compared - TEQX -> toOrdering $ go env k1 k2 - ty_ordering -> toOrdering ty_ordering - where - k1 = typeKind orig_t1 - k2 = typeKind orig_t2 - - toOrdering :: TypeOrdering -> Ordering - toOrdering TLT = LT - toOrdering TEQ = EQ - toOrdering TEQX = EQ - toOrdering TGT = GT - - liftOrdering :: Ordering -> TypeOrdering - liftOrdering LT = TLT - liftOrdering EQ = TEQ - liftOrdering GT = TGT - - thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering - thenCmpTy TEQ rel = rel - thenCmpTy TEQX rel = hasCast rel - thenCmpTy rel _ = rel - - hasCast :: TypeOrdering -> TypeOrdering - hasCast TEQ = TEQX - hasCast rel = rel - - -- Returns both the resulting ordering relation between the two types - -- and whether either contains a cast. - go :: RnEnv2 -> Type -> Type -> TypeOrdering - -- See Note [Comparing nullary type synonyms]. - go _ (TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = TEQ - go env t1 t2 - | Just t1' <- coreView t1 = go env t1' t2 - | Just t2' <- coreView t2 = go env t1 t2' - - go env (TyVarTy tv1) (TyVarTy tv2) - = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 - go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) - = go env (varType tv1) (varType tv2) - `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 - -- See Note [Equality on AppTys] - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- repSplitAppTy_maybe ty2 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- repSplitAppTy_maybe ty1 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) - -- NB: nonDepCmpTypeX does the kind check requested by - -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep - = liftOrdering (nonDetCmpTypeX env s1 s2 S.<> nonDetCmpTypeX env t1 t2) - `thenCmpTy` go env w1 w2 - -- Comparing multiplicities last because the test is usually true - go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) - = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 - go _ (LitTy l1) (LitTy l2) = liftOrdering (nonDetCmpTyLit l1 l2) - go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 - go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 - - go _ (CoercionTy {}) (CoercionTy {}) = TEQ - - -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy - go _ ty1 ty2 - = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) - where get_rank :: Type -> Int - get_rank (CastTy {}) - = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) - get_rank (TyVarTy {}) = 0 - get_rank (CoercionTy {}) = 1 - get_rank (AppTy {}) = 3 - get_rank (LitTy {}) = 4 - get_rank (TyConApp {}) = 5 - get_rank (FunTy {}) = 6 - get_rank (ForAllTy {}) = 7 - - gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering - gos _ [] [] = TEQ - gos _ [] _ = TLT - gos _ _ [] = TGT - gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 - -------------- -nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering -nonDetCmpTypesX _ [] [] = EQ -nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 S.<> - nonDetCmpTypesX env tys1 tys2 -nonDetCmpTypesX _ [] _ = LT -nonDetCmpTypesX _ _ [] = GT - -------------- --- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as --- recognized by Kind.isConstraintKindCon) which is considered a synonym for --- 'Type' in Core. --- See Note [Kind Constraint and kind Type] in "GHC.Core.Type". --- See Note [nonDetCmpType nondeterminism] -nonDetCmpTc :: TyCon -> TyCon -> Ordering -nonDetCmpTc tc1 tc2 - = assert (not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2)) $ - u1 `nonDetCmpUnique` u2 - where - u1 = tyConUnique tc1 - u2 = tyConUnique tc2 - -{- -************************************************************************ -* * The kind of a type * * ************************************************************************ -Note [typeKind vs tcTypeKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have two functions to get the kind of a type - - * typeKind ignores the distinction between Constraint and * - * tcTypeKind respects the distinction between Constraint and * - -tcTypeKind is used by the type inference engine, for which Constraint -and * are different; after that we use typeKind. - -See also Note [coreView vs tcView] - Note [Kinding rules for types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In typeKind we consider Constraint and (TYPE LiftedRep) to be identical. -We then have - - t1 : TYPE rep1 - t2 : TYPE rep2 - (FUN) ---------------- - t1 -> t2 : Type - - ty : TYPE rep - `a` is not free in rep -(FORALL) ----------------------- - forall a. ty : TYPE rep - -In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct: - - t1 : TYPE rep1 - t2 : TYPE rep2 - (FUN) ---------------- - t1 -> t2 : Type - - t1 : Constraint - t2 : TYPE rep - (PRED1) ---------------- - t1 => t2 : Type - - t1 : Constraint - t2 : Constraint - (PRED2) --------------------- - t1 => t2 : Constraint - - ty : TYPE rep +Here are the key kinding rules for types + + torc1 is TYPE or CONSTRAINT + torc2 is TYPE or CONSTRAINT + t1 : torc1 rep1 + t2 : torc2 rep2 + (FUN) ---------------- + t1 -> t2 : torc2 LiftedRep + -- In fact the arrow varies with torc1/torc2 + -- See Note [Function type constructors and FunTy] + -- in GHC.Builtin.Types.Prim + + torc is TYPE or CONSTRAINT + ty : body_torc rep + bndr_torc is Type or Constraint + ki : bndr_torc + `a` is a type variable `a` is not free in rep (FORALL1) ----------------------- - forall a. ty : TYPE rep + forall (a::ki). ty : torc rep - ty : Constraint + torc is TYPE or CONSTRAINT + ty : body_torc rep + `c` is a coercion variable + `c` is not free in rep + `c` is free in ty -- Surprise 1! (FORALL2) ------------------------- - forall a. ty : Constraint + forall (cv::k1 ~#{N,R} k2). ty : body_torc LiftedRep + -- Surprise 2! Note that: -* The only way we distinguish '->' from '=>' is by the fact - that the argument is a PredTy. Both are FunTys +* (FORALL1) rejects (forall (a::Maybe). blah) + +* (FORALL1) accepts (forall (a :: t1~t2) blah), where the type variable + (not coercion variable!) 'a' has a kind (t1~t2) that in turn has kind + Constraint. See Note [Constraints in kinds] in GHC.Core.TyCo.Rep. + +* (FORALL2) Surprise 1: + See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + +* (FORALL2) Surprise 2: coercion abstractions are not erased, so + this must be LiftedRep, just like (FUN). (FORALL2) is just a + dependent form of (FUN). + Note [Phantom type variables in kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3036,6 +2537,7 @@ occCheckExpand to expand any type synonyms in the kind of 'ty' to eliminate 'a'. See kinding rule (FORALL) in Note [Kinding rules for types] + See also * GHC.Core.Type.occCheckExpand * GHC.Core.Utils.coreAltsType @@ -3048,12 +2550,14 @@ See #14939. ----------------------------- typeKind :: HasDebugCallStack => Type -> Kind -- No need to expand synonyms -typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys -typeKind (LitTy l) = typeLiteralKind l -typeKind (FunTy {}) = liftedTypeKind -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (CastTy _ty co) = coercionRKind co -typeKind (CoercionTy co) = coercionType co +typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +typeKind (LitTy l) = typeLiteralKind l +typeKind (FunTy { ft_af = af }) = case funTyFlagResultTypeOrConstraint af of + TypeLike -> liftedTypeKind + ConstraintLike -> constraintKind +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (CastTy _ty co) = coercionRKind co +typeKind (CoercionTy co) = coercionType co typeKind (AppTy fun arg) = go fun [arg] @@ -3069,121 +2573,122 @@ typeKind ty@(ForAllTy {}) -- We must make sure tv does not occur in kind -- As it is already out of scope! -- See Note [Phantom type variables in kinds] - Just k' -> k' Nothing -> pprPanic "typeKind" (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + + Just k' | all isTyVar tvs -> k' -- Rule (FORALL1) + | otherwise -> lifted_kind_from_body -- Rule (FORALL2) where (tvs, body) = splitForAllTyVars ty body_kind = typeKind body ---------------------------------------------- --- Utilities to be used in GHC.Core.Unify, --- which uses "tc" functions ---------------------------------------------- - -tcTypeKind :: HasDebugCallStack => Type -> Kind --- No need to expand synonyms -tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys -tcTypeKind (LitTy l) = typeLiteralKind l -tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar -tcTypeKind (CastTy _ty co) = coercionRKind co -tcTypeKind (CoercionTy co) = coercionType co - -tcTypeKind (FunTy { ft_af = af, ft_res = res }) - | InvisArg <- af - , tcIsConstraintKind (tcTypeKind res) - = constraintKind -- Eq a => Ord a :: Constraint - | otherwise -- Eq a => a -> a :: TYPE LiftedRep - = liftedTypeKind -- Eq a => Array# Int :: TYPE LiftedRep (not TYPE PtrRep) - -tcTypeKind (AppTy fun arg) - = go fun [arg] - where - -- Accumulate the type arguments, so we can call piResultTys, - -- rather than a succession of calls to piResultTy (which is - -- asymptotically costly as the number of arguments increases) - go (AppTy fun arg) args = go fun (arg:args) - go fun args = piResultTys (tcTypeKind fun) args + lifted_kind_from_body -- Implements (FORALL2) + = case sORTKind_maybe body_kind of + Just (ConstraintLike, _) -> constraintKind + Just (TypeLike, _) -> liftedTypeKind + Nothing -> pprPanic "typeKind" (ppr body_kind) -tcTypeKind ty@(ForAllTy {}) - | tcIsConstraintKind body_kind - = constraintKind +--------------------------------------------- - | otherwise - = case occCheckExpand tvs body_kind of - -- We must make sure tv does not occur in kind - -- As it is already out of scope! - -- See Note [Phantom type variables in kinds] - Just k' -> k' - Nothing -> pprPanic "tcTypeKind" - (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) +sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type) +-- Sees if the argument is of form (TYPE rep) or (CONSTRAINT rep) +-- and if so returns which, and the runtime rep +-- +-- This is a "hot" function. Do not call splitTyConApp_maybe here, +-- to avoid the faff with FunTy +sORTKind_maybe (TyConApp tc tys) + -- First, short-cuts for Type and Constraint that do no allocation + | tc_uniq == liftedTypeKindTyConKey = assert( null tys ) $ Just (TypeLike, liftedRepTy) + | tc_uniq == constraintKindTyConKey = assert( null tys ) $ Just (ConstraintLike, liftedRepTy) + | tc_uniq == tYPETyConKey = get_rep TypeLike + | tc_uniq == cONSTRAINTTyConKey = get_rep ConstraintLike + | Just ty' <- expandSynTyConApp_maybe tc tys = sORTKind_maybe ty' where - (tvs, body) = splitForAllTyVars ty - body_kind = tcTypeKind body - + !tc_uniq = tyConUnique tc + -- This bang on tc_uniq is important. It means that sORTKind_maybe starts + -- by evaluating tc_uniq, and then ends up with a single case with a 4-way branch + + get_rep torc = case tys of + (rep:_reps) -> assert (null _reps) $ Just (torc, rep) + [] -> Nothing + +sORTKind_maybe _ = Nothing + +typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint +-- Precondition: expects a type that classifies values. +-- Returns whether it is TypeLike or ConstraintLike. +-- Equivalent to calling sORTKind_maybe, but faster in the FunTy case +typeTypeOrConstraint ty + = case coreFullView ty of + FunTy { ft_af = af } -> funTyFlagResultTypeOrConstraint af + ty' | Just (torc, _) <- sORTKind_maybe (typeKind ty') + -> torc + | otherwise + -> pprPanic "typeOrConstraint" (ppr ty <+> dcolon <+> ppr (typeKind ty)) isPredTy :: HasDebugCallStack => Type -> Bool +-- Precondition: expects a type that classifies values -- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep -isPredTy ty = tcIsConstraintKind (tcTypeKind ty) - --- tcIsConstraintKind stuff only makes sense in the typechecker --- After that Constraint = Type --- See Note [coreView vs tcView] --- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh) -tcIsConstraintKind :: Kind -> Bool -tcIsConstraintKind ty - | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here - , isConstraintKindCon tc - = assertPpr (null args) (ppr ty) True - - | otherwise - = False +-- Returns True for types of kind (CONSTRAINT _), False for ones of kind (TYPE _) +isPredTy ty = case typeTypeOrConstraint ty of + TypeLike -> False + ConstraintLike -> True --- | Like 'kindRep_maybe', but considers 'Constraint' to be distinct --- from 'Type'. For a version that treats them as the same type, see --- 'kindRep_maybe'. -tcKindRep_maybe :: HasDebugCallStack => Kind -> Maybe RuntimeRepType -tcKindRep_maybe kind - | Just (tc, [arg]) <- tcSplitTyConApp_maybe kind -- Note: tcSplit here - , tc `hasKey` tYPETyConKey = Just arg - | otherwise = Nothing +----------------------------------------- +-- | Does this classify a type allowed to have values? Responds True to things +-- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint. +isTYPEorCONSTRAINT :: Kind -> Bool +-- ^ True of a kind `TYPE _` or `CONSTRAINT _` +isTYPEorCONSTRAINT k = isJust (sORTKind_maybe k) + +isConstraintLikeKind :: Kind -> Bool +-- True of (CONSTRAINT _) +isConstraintLikeKind kind + = case sORTKind_maybe kind of + Just (ConstraintLike, _) -> True + _ -> False + +isConstraintKind :: Kind -> Bool +-- True of (CONSTRAINT LiftedRep) +isConstraintKind kind + = case sORTKind_maybe kind of + Just (ConstraintLike, rep) -> isLiftedRuntimeRep rep + _ -> False --- | Is this kind equivalent to 'Type'? --- --- This considers 'Constraint' to be distinct from 'Type'. For a version that --- treats them as the same type, see 'isLiftedTypeKind'. tcIsLiftedTypeKind :: Kind -> Bool +-- ^ Is this kind equivalent to 'Type' i.e. TYPE LiftedRep? tcIsLiftedTypeKind kind - = case tcKindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep - Nothing -> False + | Just (TypeLike, rep) <- sORTKind_maybe kind + = isLiftedRuntimeRep rep + | otherwise + = False --- | Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@? --- --- This considers 'Constraint' to be distinct from 'Type'. For a version that --- treats them as the same type, see 'isLiftedTypeKind'. tcIsBoxedTypeKind :: Kind -> Bool +-- ^ Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@? tcIsBoxedTypeKind kind - = case tcKindRep_maybe kind of - Just rep -> isBoxedRuntimeRep rep - Nothing -> False + | Just (TypeLike, rep) <- sORTKind_maybe kind + = isBoxedRuntimeRep rep + | otherwise + = False -- | Is this kind equivalent to @TYPE r@ (for some unknown r)? -- -- This considers 'Constraint' to be distinct from @*@. -tcIsRuntimeTypeKind :: Kind -> Bool -tcIsRuntimeTypeKind kind = isJust (tcKindRep_maybe kind) +isTypeLikeKind :: Kind -> Bool +isTypeLikeKind kind + = case sORTKind_maybe kind of + Just (TypeLike, _) -> True + _ -> False -tcReturnsConstraintKind :: Kind -> Bool +returnsConstraintKind :: Kind -> Bool -- True <=> the Kind ultimately returns a Constraint -- E.g. * -> Constraint -- forall k. k -> Constraint -tcReturnsConstraintKind kind - | Just kind' <- tcView kind = tcReturnsConstraintKind kind' -tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty -tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty -tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc -tcReturnsConstraintKind _ = False +returnsConstraintKind kind + | Just kind' <- coreView kind = returnsConstraintKind kind' +returnsConstraintKind (ForAllTy _ ty) = returnsConstraintKind ty +returnsConstraintKind (FunTy { ft_res = ty }) = returnsConstraintKind ty +returnsConstraintKind kind = isConstraintLikeKind kind -------------------------- typeLiteralKind :: TyLit -> Kind @@ -3194,11 +2699,11 @@ typeLiteralKind (CharTyLit {}) = charTy -- | Returns True if a type has a syntactically fixed runtime rep, -- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- --- This function is equivalent to @('isFixedRuntimeRepKind' . 'typeKind')@, +-- This function is equivalent to `isFixedRuntimeRepKind . typeKind` -- but much faster. -- -- __Precondition:__ The type has kind @('TYPE' blah)@ -typeHasFixedRuntimeRep :: Type -> Bool +typeHasFixedRuntimeRep :: HasDebugCallStack => Type -> Bool typeHasFixedRuntimeRep = go where go (TyConApp tc _) @@ -3214,361 +2719,22 @@ argsHaveFixedRuntimeRep :: Type -> Bool argsHaveFixedRuntimeRep ty = all ok bndrs where - ok :: TyCoBinder -> Bool - ok (Anon _ ty) = typeHasFixedRuntimeRep (scaledThing ty) + ok :: PiTyBinder -> Bool + ok (Anon ty _) = typeHasFixedRuntimeRep (scaledThing ty) ok _ = True - bndrs :: [TyCoBinder] + bndrs :: [PiTyBinder] (bndrs, _) = splitPiTys ty -{- ********************************************************************** -* * - Occurs check expansion -%* * -%********************************************************************* -} - -{- Note [Occurs check expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid -of occurrences of tv outside type function arguments, if that is -possible; otherwise, it returns Nothing. - -For example, suppose we have - type F a b = [a] -Then - occCheckExpand b (F Int b) = Just [Int] -but - occCheckExpand a (F a Int) = Nothing - -We don't promise to do the absolute minimum amount of expanding -necessary, but we try not to do expansions we don't need to. We -prefer doing inner expansions first. For example, - type F a b = (a, Int, a, [a]) - type G b = Char -We have - occCheckExpand b (F (G b)) = Just (F Char) -even though we could also expand F to get rid of b. - -Note [Occurrence checking: look inside kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are considering unifying - (alpha :: *) ~ Int -> (beta :: alpha -> alpha) -This may be an error (what is that alpha doing inside beta's kind?), -but we must not make the mistake of actually unifying or we'll -build an infinite data structure. So when looking for occurrences -of alpha in the rhs, we must look in the kinds of type variables -that occur there. - -occCheckExpand tries to expand type synonyms to remove -unnecessary occurrences of a variable, and thereby get past an -occurs-check failure. This is good; but - we can't do it in the /kind/ of a variable /occurrence/ - -For example #18451 built an infinite type: - type Const a b = a - data SameKind :: k -> k -> Type - type T (k :: Const Type a) = forall (b :: k). SameKind a b - -We have - b :: k - k :: Const Type a - a :: k (must be same as b) - -So if we aren't careful, a's kind mentions a, which is bad. -And expanding an /occurrence/ of 'a' doesn't help, because the -/binding site/ is the master copy and all the occurrences should -match it. - -Here's a related example: - f :: forall a b (c :: Const Type b). Proxy '[a, c] - -The list means that 'a' gets the same kind as 'c'; but that -kind mentions 'b', so the binders are out of order. - -Bottom line: in occCheckExpand, do not expand inside the kinds -of occurrences. See bad_var_occ in occCheckExpand. And -see #18451 for more debate. --} - -occCheckExpand :: [Var] -> Type -> Maybe Type --- See Note [Occurs check expansion] --- We may have needed to do some type synonym unfolding in order to --- get rid of the variable (or forall), so we also return the unfolded --- version of the type, which is guaranteed to be syntactically free --- of the given type variable. If the type is already syntactically --- free of the variable, then the same type is returned. -occCheckExpand vs_to_avoid ty - | null vs_to_avoid -- Efficient shortcut - = Just ty -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase - - | otherwise - = go (mkVarSet vs_to_avoid, emptyVarEnv) ty - where - go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type - -- The VarSet is the set of variables we are trying to avoid - -- The VarEnv carries mappings necessary - -- because of kind expansion - go (as, env) ty@(TyVarTy tv) - | Just tv' <- lookupVarEnv env tv = return (mkTyVarTy tv') - | bad_var_occ as tv = Nothing - | otherwise = return ty - - go _ ty@(LitTy {}) = return ty - go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (mkAppTy ty1' ty2') } - go cxt ty@(FunTy _ w ty1 ty2) - = do { w' <- go cxt w - ; ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) } - go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) - = do { ki' <- go cxt (varType tv) - ; let tv' = setVarType tv ki' - env' = extendVarEnv env tv tv' - as' = as `delVarSet` tv - ; body' <- go (as', env') body_ty - ; return (ForAllTy (Bndr tv' vis) body') } - - -- For a type constructor application, first try expanding away the - -- offending variable from the arguments. If that doesn't work, next - -- see if the type constructor is a type synonym, and if so, expand - -- it and try again. - go cxt ty@(TyConApp tc tys) - = case mapM (go cxt) tys of - Just tys' -> return (mkTyConApp tc tys') - Nothing | Just ty' <- tcView ty -> go cxt ty' - | otherwise -> Nothing - -- Failing that, try to expand a synonym - - go cxt (CastTy ty co) = do { ty' <- go cxt ty - ; co' <- go_co cxt co - ; return (mkCastTy ty' co') } - go cxt (CoercionTy co) = do { co' <- go_co cxt co - ; return (mkCoercionTy co') } - - ------------------ - bad_var_occ :: VarSet -> Var -> Bool - -- Works for TyVar and CoVar - -- See Note [Occurrence checking: look inside kinds] - bad_var_occ vs_to_avoid v - = v `elemVarSet` vs_to_avoid - || tyCoVarsOfType (varType v) `intersectsVarSet` vs_to_avoid - - ------------------ - go_mco _ MRefl = return MRefl - go_mco ctx (MCo co) = MCo <$> go_co ctx co - - ------------------ - go_co cxt (Refl ty) = do { ty' <- go cxt ty - ; return (mkNomReflCo ty') } - go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco - ; ty' <- go cxt ty - ; return (mkGReflCo r ty' mco') } - -- Note: Coercions do not contain type synonyms - go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args - ; return (mkTyConAppCo r tc args') } - go_co cxt (AppCo co arg) = do { co' <- go_co cxt co - ; arg' <- go_co cxt arg - ; return (mkAppCo co' arg') } - go_co cxt@(as, env) (ForAllCo tv kind_co body_co) - = do { kind_co' <- go_co cxt kind_co - ; let tv' = setVarType tv $ - coercionLKind kind_co' - env' = extendVarEnv env tv tv' - as' = as `delVarSet` tv - ; body' <- go_co (as', env') body_co - ; return (ForAllCo tv' kind_co' body') } - go_co cxt (FunCo r w co1 co2) = do { co1' <- go_co cxt co1 - ; co2' <- go_co cxt co2 - ; w' <- go_co cxt w - ; return (mkFunCo r w' co1' co2') } - go_co (as,env) co@(CoVarCo c) - | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') - | bad_var_occ as c = Nothing - | otherwise = return co - - go_co (as,_) co@(HoleCo h) - | bad_var_occ as (ch_co_var h) = Nothing - | otherwise = return co - - go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args - ; return (mkAxiomInstCo ax ind args') } - go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p - ; ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (mkUnivCo p' r ty1' ty2') } - go_co cxt (SymCo co) = do { co' <- go_co cxt co - ; return (mkSymCo co') } - go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 - ; co2' <- go_co cxt co2 - ; return (mkTransCo co1' co2') } - go_co cxt (NthCo r n co) = do { co' <- go_co cxt co - ; return (mkNthCo r n co') } - go_co cxt (LRCo lr co) = do { co' <- go_co cxt co - ; return (mkLRCo lr co') } - go_co cxt (InstCo co arg) = do { co' <- go_co cxt co - ; arg' <- go_co cxt arg - ; return (mkInstCo co' arg') } - go_co cxt (KindCo co) = do { co' <- go_co cxt co - ; return (mkKindCo co') } - go_co cxt (SubCo co) = do { co' <- go_co cxt co - ; return (mkSubCo co') } - go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs - ; return (mkAxiomRuleCo ax cs') } - - ------------------ - go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co - go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co - go_prov _ p@(PluginProv _) = return p - go_prov _ p@(CorePrepProv _) = return p - - -{- -%************************************************************************ -%* * - Miscellaneous functions -%* * -%************************************************************************ - --} --- | All type constructors occurring in the type; looking through type --- synonyms, but not newtypes. --- When it finds a Class, it returns the class TyCon. -tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty - = go ty - where - go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy {}) = emptyUniqSet - go (LitTy {}) = emptyUniqSet - go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys - go (AppTy a b) = go a `unionUniqSets` go b - go (FunTy _ w a b) = go w `unionUniqSets` - go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon - go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) - go (CastTy ty co) = go ty `unionUniqSets` go_co co - go (CoercionTy co) = go_co co - - go_co (Refl ty) = go ty - go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco - go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args - go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg - go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co - go_co (FunCo _ co_mult co1 co2) = go_co co_mult `unionUniqSets` go_co co1 `unionUniqSets` go_co co2 - go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args - go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 - go_co (CoVarCo {}) = emptyUniqSet - go_co (HoleCo {}) = emptyUniqSet - go_co (SymCo co) = go_co co - go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 - go_co (NthCo _ _ co) = go_co co - go_co (LRCo _ co) = go_co co - go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg - go_co (KindCo co) = go_co co - go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_cos cs - - go_mco MRefl = emptyUniqSet - go_mco (MCo co) = go_co co - - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyUniqSet - go_prov (CorePrepProv _) = emptyUniqSet - -- this last case can happen from the tyConsOfType used from - -- checkTauTvUpdate - - go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys - go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos - - go_tc tc = unitUniqSet tc - go_ax ax = go_tc $ coAxiomTyCon ax - --- | Retrieve the free variables in this type, splitting them based --- on whether they are used visibly or invisibly. Invisible ones come --- first. -splitVisVarsOfType :: Type -> Pair TyCoVarSet -splitVisVarsOfType orig_ty = Pair invis_vars vis_vars - where - Pair invis_vars1 vis_vars = go orig_ty - invis_vars = invis_vars1 `minusVarSet` vis_vars - - go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) - go (AppTy t1 t2) = go t1 `mappend` go t2 - go (TyConApp tc tys) = go_tc tc tys - go (FunTy _ w t1 t2) = go w `mappend` go t1 `mappend` go t2 - go (ForAllTy (Bndr tv _) ty) - = ((`delVarSet` tv) <$> go ty) `mappend` - (invisible (tyCoVarsOfType $ varType tv)) - go (LitTy {}) = mempty - go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) - go (CoercionTy co) = invisible $ tyCoVarsOfCo co - - invisible vs = Pair vs emptyVarSet - - go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in - invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis - -splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet -splitVisVarsOfTypes = foldMap splitVisVarsOfType - -{- -************************************************************************ -* * - Functions over Kinds -* * -************************************************************************ - -Note [Kind Constraint and kind Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The kind Constraint is the kind of classes and other type constraints. -The special thing about types of kind Constraint is that - * They are displayed with double arrow: - f :: Ord a => a -> a - * They are implicitly instantiated at call sites; so the type inference - engine inserts an extra argument of type (Ord a) at every call site - to f. - -However, once type inference is over, there is *no* distinction between -Constraint and Type. Indeed we can have coercions between the two. Consider - class C a where - op :: a -> a -For this single-method class we may generate a newtype, which in turn -generates an axiom witnessing - C a ~ (a -> a) -so on the left we have Constraint, and on the right we have Type. -See #7451. - -Because we treat Constraint/Type differently during and after type inference, -GHC has two notions of equality that differ in whether they equate -Constraint/Type or not: - -* GHC.Tc.Utils.TcType.tcEqType implements typechecker equality (see - Note [Typechecker equality vs definitional equality] in GHC.Tc.Utils.TcType), - which treats Constraint and Type as distinct. This is used during type - inference. See #11715 for issues that arise from this. -* GHC.Core.TyCo.Rep.eqType implements definitional equality (see - Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep), which treats - Constraint and Type as equal. This is used after type inference. - -Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with -distinct uniques, they are treated as equal at all times except -during type inference. --} - -- | Checks that a kind of the form 'Type', 'Constraint' -- or @'TYPE r@ is concrete. See 'isConcrete'. -- --- __Precondition:__ The type has kind @('TYPE' blah)@. +-- __Precondition:__ The type has kind `TYPE blah` or `CONSTRAINT blah` isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool isFixedRuntimeRepKind k - = assertPpr (isLiftedTypeKind k || _is_type) (ppr k) $ + = assertPpr (isTYPEorCONSTRAINT k) (ppr k) $ -- the isLiftedTypeKind check is necessary b/c of Constraint isConcrete k - where - _is_type = classifiesTypeWithValues k -- | Tests whether the given type is concrete, i.e. it -- whether it consists only of concrete type constructors, @@ -3592,12 +2758,6 @@ isConcrete = go go CastTy{} = False go CoercionTy{} = False ------------------------------------------ --- | Does this classify a type allowed to have values? Responds True to things --- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint. -classifiesTypeWithValues :: Kind -> Bool --- ^ True of any sub-kind of OpenTypeKind -classifiesTypeWithValues k = isJust (kindRep_maybe k) {- %************************************************************************ @@ -3645,7 +2805,8 @@ tyConAppNeedsKindSig spec_inj_pos tc n_args injective_vars_of_binder :: TyConBinder -> FV injective_vars_of_binder (Bndr tv vis) = case vis of - AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice + AnonTCB af | isVisibleFunArg af + -> injectiveVarsOfType False -- conservative choice (varType tv) NamedTCB argf | source_of_injectivity argf -> unitFV tv `unionFV` @@ -3893,13 +3054,13 @@ their friends here with them. unrestricted, linear, tymult :: a -> Scaled a -- | Scale a payload by Many -unrestricted = Scaled Many +unrestricted = Scaled ManyTy -- | Scale a payload by One -linear = Scaled One +linear = Scaled OneTy -- | Scale a payload by Many; used for type arguments in core -tymult = Scaled Many +tymult = Scaled ManyTy irrelevantMult :: Scaled a -> a irrelevantMult = scaledThing @@ -3910,25 +3071,25 @@ mkScaled = Scaled scaledSet :: Scaled a -> b -> Scaled b scaledSet (Scaled m _) b = Scaled m b -pattern One :: Mult -pattern One <- (isOneDataConTy -> True) - where One = oneDataConTy +pattern OneTy :: Mult +pattern OneTy <- (isOneTy -> True) + where OneTy = oneDataConTy -pattern Many :: Mult -pattern Many <- (isManyDataConTy -> True) - where Many = manyDataConTy +pattern ManyTy :: Mult +pattern ManyTy <- (isManyTy -> True) + where ManyTy = manyDataConTy -isManyDataConTy :: Mult -> Bool -isManyDataConTy ty +isManyTy :: Mult -> Bool +isManyTy ty | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` manyDataConKey -isManyDataConTy _ = False +isManyTy _ = False -isOneDataConTy :: Mult -> Bool -isOneDataConTy ty +isOneTy :: Mult -> Bool +isOneTy ty | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` oneDataConKey -isOneDataConTy _ = False +isOneTy _ = False isLinearType :: Type -> Bool -- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function @@ -3936,7 +3097,210 @@ isLinearType :: Type -> Bool -- this function to check whether it is safe to eta reduce an Id in CorePrep. It -- is always safe to return 'True', because 'True' deactivates the optimisation. isLinearType ty = case ty of - FunTy _ Many _ res -> isLinearType res - FunTy _ _ _ _ -> True - ForAllTy _ res -> isLinearType res + FunTy _ ManyTy _ res -> isLinearType res + FunTy _ _ _ _ -> True + ForAllTy _ res -> isLinearType res _ -> False + +{- ********************************************************************* +* * + Space-saving construction +* * +********************************************************************* -} + +{- Note [Using synonyms to compress types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Was: [Prefer Type over TYPE (BoxedRep Lifted)] + +The Core of nearly any program will have numerous occurrences of the Types + + TyConApp BoxedRep [TyConApp Lifted []] -- Synonym LiftedRep + TyConApp BoxedRep [TyConApp Unlifted []] -- Synonym UnliftedREp + TyConApp TYPE [TyConApp LiftedRep []] -- Synonym Type + TyConApp TYPE [TyConApp UnliftedRep []] -- Synonym UnliftedType + +While investigating #17292 we found that these constituted a majority +of all TyConApp constructors on the heap: + + (From a sample of 100000 TyConApp closures) + 0x45f3523 - 28732 - `Type` + 0x420b840702 - 9629 - generic type constructors + 0x42055b7e46 - 9596 + 0x420559b582 - 9511 + 0x420bb15a1e - 9509 + 0x420b86c6ba - 9501 + 0x42055bac1e - 9496 + 0x45e68fd - 538 - `TYPE ...` + +Consequently, we try hard to ensure that operations on such types are +efficient. Specifically, we strive to + + a. Avoid heap allocation of such types; use a single static TyConApp + b. Use a small (shallow in the tree-depth sense) representation + for such types + +Goal (b) is particularly useful as it makes traversals (e.g. free variable +traversal, substitution, and comparison) more efficient. +Comparison in particular takes special advantage of nullary type synonym +applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing +nullary type synonyms] in "GHC.Core.Type". + +To accomplish these we use a number of tricks, implemented by mkTyConApp. + + 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]), + we prefer a statically-allocated (TyConApp LiftedRep []) + where `LiftedRep` is a type synonym: + type LiftedRep = BoxedRep Lifted + Similarly for UnliftedRep + + 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []]) + we prefer the statically-allocated (TyConApp Type []) + where `Type` is a type synonym + type Type = TYPE LiftedRep + Similarly for UnliftedType + +These serve goal (b) since there are no applied type arguments to traverse, +e.g., during comparison. + + 3. We have a single, statically allocated top-level binding to + represent `TyConApp GHC.Types.Type []` (namely + 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't + need to allocate such types (goal (a)). See functions + mkTYPEapp and mkBoxedRepApp + + 4. We use the sharing mechanism described in Note [Sharing nullary TyConApps] + in GHC.Core.TyCon to ensure that we never need to allocate such + nullary applications (goal (a)). + +See #17958, #20541 +-} + +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon [] + = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon + mkTyConTy tycon + +mkTyConApp tycon tys@(ty1:rest) + | Just fun_ty <- tyConAppFunTy_maybe tycon tys + = fun_ty + + -- See Note [Using synonyms to compress types] + | key == tYPETyConKey + , Just ty <- mkTYPEapp_maybe ty1 + = assert (null rest) ty + + | key == cONSTRAINTTyConKey + , Just ty <- mkCONSTRAINTapp_maybe ty1 + = assert (null rest) ty + + -- See Note [Using synonyms to compress types] + | key == boxedRepDataConTyConKey + , Just ty <- mkBoxedRepApp_maybe ty1 + = assert (null rest) ty + + | key == tupleRepDataConTyConKey + , Just ty <- mkTupleRepApp_maybe ty1 + = assert (null rest) ty + + -- The catch-all case + | otherwise + = TyConApp tycon tys + where + key = tyConUnique tycon + + +{- Note [Care using synonyms to compress types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Using a synonym to compress a types has a tricky wrinkle. Consider +coreView applied to (TyConApp LiftedRep []) + +* coreView expands the LiftedRep synonym: + type LiftedRep = BoxedRep Lifted + +* Danger: we might apply the empty substitution to the RHS of the + synonym. And substTy calls mkTyConApp BoxedRep [Lifted]. And + mkTyConApp compresses that back to LiftedRep. Loop! + +* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary + type synonyms. That's more efficient anyway. +-} + + +mkTYPEapp :: RuntimeRepType -> Type +mkTYPEapp rr + = case mkTYPEapp_maybe rr of + Just ty -> ty + Nothing -> TyConApp tYPETyCon [rr] + +mkTYPEapp_maybe :: RuntimeRepType -> Maybe Type +-- ^ Given a @RuntimeRep@, applies @TYPE@ to it. +-- On the fly it rewrites +-- TYPE LiftedRep --> liftedTypeKind (a synonym) +-- TYPE UnliftedRep --> unliftedTypeKind (ditto) +-- TYPE ZeroBitRep --> zeroBitTypeKind (ditto) +-- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted) +-- because those inner types should already have been rewritten +-- to LiftedRep and UnliftedRep respectively, by mkTyConApp +-- +-- see Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkTYPEapp_maybe #-} +mkTYPEapp_maybe (TyConApp tc args) + | key == liftedRepTyConKey = assert (null args) $ Just liftedTypeKind -- TYPE LiftedRep + | key == unliftedRepTyConKey = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep + | key == zeroBitRepTyConKey = assert (null args) $ Just zeroBitTypeKind -- TYPE ZeroBitRep + where + key = tyConUnique tc +mkTYPEapp_maybe _ = Nothing + +------------------ +mkCONSTRAINTapp :: RuntimeRepType -> Type +-- ^ Just like mkTYPEapp +mkCONSTRAINTapp rr + = case mkCONSTRAINTapp_maybe rr of + Just ty -> ty + Nothing -> TyConApp cONSTRAINTTyCon [rr] + +mkCONSTRAINTapp_maybe :: RuntimeRepType -> Maybe Type +-- ^ Just like mkTYPEapp_maybe +{-# NOINLINE mkCONSTRAINTapp_maybe #-} +mkCONSTRAINTapp_maybe (TyConApp tc args) + | key == liftedRepTyConKey = assert (null args) $ Just constraintKind -- CONSTRAINT LiftedRep + where + key = tyConUnique tc +mkCONSTRAINTapp_maybe _ = Nothing + +------------------ +mkBoxedRepApp_maybe :: LevityType -> Maybe Type +-- ^ Given a `Levity`, apply `BoxedRep` to it +-- On the fly, rewrite +-- BoxedRep Lifted --> liftedRepTy (a synonym) +-- BoxedRep Unlifted --> unliftedRepTy (ditto) +-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkBoxedRepApp_maybe #-} +mkBoxedRepApp_maybe (TyConApp tc args) + | key == liftedDataConKey = assert (null args) $ Just liftedRepTy -- BoxedRep Lifted + | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy -- BoxedRep Unlifted + where + key = tyConUnique tc +mkBoxedRepApp_maybe _ = Nothing + +mkTupleRepApp_maybe :: Type -> Maybe Type +-- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it +-- On the fly, rewrite +-- TupleRep [] -> zeroBitRepTy (a synonym) +-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkTupleRepApp_maybe #-} +mkTupleRepApp_maybe (TyConApp tc args) + | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy -- ZeroBitRep + where + key = tyConUnique tc +mkTupleRepApp_maybe _ = Nothing + +typeOrConstraintKind :: TypeOrConstraint -> RuntimeRepType -> Kind +typeOrConstraintKind TypeLike rep = mkTYPEapp rep +typeOrConstraintKind ConstraintLike rep = mkCONSTRAINTapp rep diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot index 5b91063a08..7b14a22fc1 100644 --- a/compiler/GHC/Core/Type.hs-boot +++ b/compiler/GHC/Core/Type.hs-boot @@ -4,29 +4,35 @@ module GHC.Core.Type where import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCon -import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, RuntimeRepType, Coercion ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion ) import GHC.Utils.Misc +import GHC.Types.Var( FunTyFlag, TyVar ) +import GHC.Types.Basic( TypeOrConstraint ) isPredTy :: HasDebugCallStack => Type -> Bool isCoercionTy :: Type -> Bool mkAppTy :: Type -> Type -> Type mkCastTy :: Type -> Coercion -> Type -mkTyConTy :: TyCon -> Type mkTyConApp :: TyCon -> [Type] -> Type +mkCoercionTy :: Coercion -> Type piResultTy :: HasDebugCallStack => Type -> Type -> Type +typeKind :: HasDebugCallStack => Type -> Type +typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint + coreView :: Type -> Maybe Type -tcView :: Type -> Maybe Type isRuntimeRepTy :: Type -> Bool isLevityTy :: Type -> Bool isMultiplicityTy :: Type -> Bool isLiftedTypeKind :: Type -> Bool -mkTYPEapp :: RuntimeRepType -> Type splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) tyConAppTyCon_maybe :: Type -> Maybe TyCon +getTyVar_maybe :: Type -> Maybe TyVar getLevity :: HasDebugCallStack => Type -> Type partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) + +chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index 596fef6b6f..e0594cb811 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -10,21 +10,19 @@ module GHC.Core.Unify ( tcMatchTyX, tcMatchTysX, tcMatchTyKisX, tcMatchTyX_BM, ruleMatchTyKiX, - -- * Rough matching - RoughMatchTc(..), roughMatchTcs, roughMatchTcsLookup, instanceCantMatch, - typesCantMatch, isRoughWildcard, - -- Side-effect free unification tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, tcUnifyTysFG, tcUnifyTyWithTFs, BindFun, BindFlag(..), matchBindFun, alwaysBindFun, UnifyResult, UnifyResultM(..), MaybeApartReason(..), + typesCantMatch, typesAreApart, -- Matching a type against a lifted type (coercion) liftCoMatch, -- The core flattening algorithm - flattenTys, flattenTysX + flattenTys, flattenTysX, + ) where import GHC.Prelude @@ -37,9 +35,9 @@ import GHC.Core.Type hiding ( getTvSubstEnv ) import GHC.Core.Coercion hiding ( getCvSubstEnv ) import GHC.Core.TyCon import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) -import GHC.Core.TyCo.Subst ( mkTvSubst, emptyIdSubstEnv ) -import GHC.Core.RoughMap +import GHC.Core.TyCo.Compare ( eqType, tcEqType ) +import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) +import GHC.Core.TyCo.Subst ( mkTvSubst, emptyIdSubstEnv ) import GHC.Core.Map.Type import GHC.Utils.FV( FV, fvVarList ) import GHC.Utils.Misc @@ -48,7 +46,6 @@ import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set -import {-# SOURCE #-} GHC.Tc.Utils.TcType ( tcEqType ) import GHC.Exts( oneShot ) import GHC.Utils.Panic.Plain import GHC.Data.FastString @@ -57,8 +54,6 @@ import Data.List ( mapAccumL ) import Control.Monad import qualified Data.Semigroup as S -import GHC.Builtin.Names (constraintKindTyConKey, liftedTypeKindTyConKey) - {- Unification is much tricker than you might think. @@ -161,7 +156,7 @@ tcMatchTyX subst ty1 ty2 -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTys :: [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe Subst -- ^ One-shot; in principle the template + -> Maybe Subst -- ^ One-shot; in principle the template -- variables could be free in the target tcMatchTys tys1 tys2 = tc_match_tys alwaysBindFun False tys1 tys2 @@ -254,62 +249,6 @@ matchBindFun tvs tv _ty alwaysBindFun :: BindFun alwaysBindFun _tv _ty = BindMe -{- ********************************************************************* -* * - Rough matching -* * -********************************************************************* -} - -{- Note [Rough matching in class and family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - instance C (Maybe [Tree a]) Bool -and suppose we are looking up - C Bool Bool - -We can very quickly rule the instance out, because the first -argument is headed by Maybe, whereas in the constraint we are looking -up has first argument headed by Bool. These "headed by" TyCons are -called the "rough match TyCons" of the constraint or instance. -They are used for a quick filter, to check when an instance cannot -possibly match. - -The main motivation is to avoid sucking in whole instance -declarations that are utterly useless. See GHC.Core.InstEnv -Note [ClsInst laziness and the rough-match fields]. - -INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon, -like Maybe or Either, including a newtype or a data family, both of -which are generative. It replies True to `isGenerativeTyCon tc Nominal`. - -But it is never - - A type synonym - E.g. Int and (S Bool) might match - if (S Bool) is a synonym for Int - - - A type family (#19336) - E.g. (Just a) and (F a) might match if (F a) reduces to (Just a) - albeit perhaps only after 'a' is instantiated. --} - -roughMatchTcs :: [Type] -> [RoughMatchTc] -roughMatchTcs tys = map typeToRoughMatchTc tys - -roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc] -roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys - -instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool --- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot --- possibly be instantiated to actual, nor vice versa; --- False is non-committal -instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as -instanceCantMatch _ _ = False -- Safe - -itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool -itemCantMatch (RM_KnownTc t) (RM_KnownTc a) = t /= a -itemCantMatch _ _ = False - - {- ************************************************************************ * * @@ -351,13 +290,12 @@ suffices. -- apart, even after arbitrary type function evaluation and substitution? typesCantMatch :: [(Type,Type)] -> Bool -- See Note [Pruning dead case alternatives] -typesCantMatch prs = any (uncurry cant_match) prs - where - cant_match :: Type -> Type -> Bool - cant_match t1 t2 = case tcUnifyTysFG alwaysBindFun [t1] [t2] of - SurelyApart -> True - _ -> False +typesCantMatch prs = any (uncurry typesAreApart) prs +typesAreApart :: Type -> Type -> Bool +typesAreApart t1 t2 = case tcUnifyTysFG alwaysBindFun [t1] [t2] of + SurelyApart -> True + _ -> False {- ************************************************************************ * * @@ -538,10 +476,13 @@ data UnifyResultM a = Unifiable a -- the subst that unifies the types -- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv -- As of Feb 2022, we never differentiate between MARTypeFamily and MARTypeVsConstraint; -- it's really only MARInfinite that's interesting here. -data MaybeApartReason = MARTypeFamily -- ^ matching e.g. F Int ~? Bool - | MARInfinite -- ^ matching e.g. a ~? Maybe a - | MARTypeVsConstraint -- ^ matching Type ~? Constraint - -- See Note [coreView vs tcView] in GHC.Core.Type +data MaybeApartReason + = MARTypeFamily -- ^ matching e.g. F Int ~? Bool + + | MARInfinite -- ^ matching e.g. a ~? Maybe a + + | MARTypeVsConstraint -- ^ matching Type ~? Constraint or the arrow types + -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim instance Outputable MaybeApartReason where ppr MARTypeFamily = text "MARTypeFamily" @@ -943,10 +884,18 @@ the equality between the substed kind of the left-hand type and the substed kind of the right-hand type. Note that we do not unify kinds at the leaves (as we did previously). We thus have -INVARIANT: In the call - unify_ty ty1 ty2 kco -it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where -`subst` is the ambient substitution in the UM monad. +Hence: (Unification Kind Invariant) +----------------------------------- +In the call + unify_ty ty1 ty2 kco +it must be that + subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)) +where `subst` is the ambient substitution in the UM monad. And in the call + unify_tys tys1 tys2 +(which has no kco), after we unify any prefix of tys1,tys2, the kinds of the +head of the remaining tys1,tys2 are identical after substitution. This +implies, for example, that the kinds of the head of tys1,tys2 are identical +after substitution. To get this coercion, we first have to match/unify the kinds before looking at the types. Happily, we need look only one level @@ -1057,6 +1006,8 @@ unify_ty :: UMEnv -> CoercionN -- A coercion between their kinds -- See Note [Kind coercions in Unify] -> UM () +-- Precondition: see (Unification Kind Invariant) +-- -- See Note [Specification of unification] -- Respects newtypes, PredTypes -- See Note [Computing equality on types] in GHC.Core.Type @@ -1065,19 +1016,10 @@ unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco | tc1 == tc2 = return () - -- See Note [coreView vs tcView] in GHC.Core.Type. - | tc1 `hasKey` constraintKindTyConKey - , tc2 `hasKey` liftedTypeKindTyConKey - = maybeApart MARTypeVsConstraint - - | tc2 `hasKey` constraintKindTyConKey - , tc1 `hasKey` liftedTypeKindTyConKey - = maybeApart MARTypeVsConstraint - unify_ty env ty1 ty2 kco -- Now handle the cases we can "look through": synonyms and casts. - | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco - | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco + | Just ty1' <- coreView ty1 = unify_ty env ty1' ty2 kco + | Just ty2' <- coreView ty2 = unify_ty env ty1 ty2' kco | CastTy ty1' co <- ty1 = if um_unif env then unify_ty env ty1' ty2 (co `mkTransCo` kco) else -- See Note [Matching in the presence of casts (1)] @@ -1093,8 +1035,6 @@ unify_ty env ty1 (TyVarTy tv2) kco = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) unify_ty env ty1 ty2 _kco - -- NB: This keeps Constraint and Type distinct, as it should for use in the - -- type-checker. | Just (tc1, tys1) <- mb_tc_app1 , Just (tc2, tys2) <- mb_tc_app2 , tc1 == tc2 @@ -1130,32 +1070,44 @@ unify_ty env ty1 ty2 _kco -- NB: we have already dealt with the 'ty1 = variable' case = maybeApart MARTypeFamily + -- TYPE and CONSTRAINT are not Apart + -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + -- NB: at this point we know that the two TyCons do not match + | Just {} <- sORTKind_maybe ty1 + , Just {} <- sORTKind_maybe ty2 + = maybeApart MARTypeVsConstraint + -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim + -- Note [Type and Constraint are not apart] + + -- The arrow types are not Apart + -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + -- wrinkle (W2) + -- NB1: at this point we know that the two TyCons do not match + -- NB2: In the common FunTy/FunTy case you might wonder if we want to go via + -- splitTyConApp_maybe. But yes we do: we need to look at those implied + -- kind argument in order to satisfy (Unification Kind Invariant) + | FunTy {} <- ty1 + , FunTy {} <- ty2 + = maybeApart MARTypeVsConstraint + -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim + -- Note [Type and Constraint are not apart] + where - mb_tc_app1 = tcSplitTyConApp_maybe ty1 - mb_tc_app2 = tcSplitTyConApp_maybe ty2 + mb_tc_app1 = splitTyConApp_maybe ty1 + mb_tc_app2 = splitTyConApp_maybe ty2 -- Applications need a bit of care! -- They can match FunTy and TyConApp, so use splitAppTy_maybe -- NB: we've already dealt with type variables, -- so if one type is an App the other one jolly well better be too unify_ty env (AppTy ty1a ty1b) ty2 _kco - | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + | Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 = unify_ty_app env ty1a [ty1b] ty2a [ty2b] unify_ty env ty1 (AppTy ty2a ty2b) _kco - | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -- tcSplitTyConApp won't split a (=>), so we handle this separately. -unify_ty env (FunTy InvisArg _w1 arg1 res1) (FunTy InvisArg _w2 arg2 res2) _kco - -- Look at result representations, but arg representations would be redundant - -- as anything that can appear to the left of => is lifted. - -- And anything that can appear to the left of => is unrestricted, so skip the - -- multiplicities. - | Just res_rep1 <- getRuntimeRep_maybe res1 - , Just res_rep2 <- getRuntimeRep_maybe res2 - = unify_tys env [res_rep1, arg1, res1] [res_rep2, arg2, res2] - unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco @@ -1170,7 +1122,7 @@ unify_ty env (CoercionTy co1) (CoercionTy co2) kco CoVarCo cv | not (um_unif env) , not (cv `elemVarEnv` c_subst) - , let (_, co_l, co_r) = decomposeFunCo Nominal kco + , let (_, co_l, co_r) = decomposeFunCo kco -- Because the coercion is used in a type, it should be safe to -- ignore the multiplicity coercion. -- cv :: t1 ~ t2 @@ -1187,8 +1139,8 @@ unify_ty _ _ _ _ = surelyApart unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () unify_ty_app env ty1 ty1args ty2 ty2args - | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 - , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 + | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 + , Just (ty2', ty2a) <- splitAppTyNoView_maybe ty2 = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) | otherwise @@ -1202,6 +1154,7 @@ unify_ty_app env ty1 ty1args ty2 ty2args ; unify_tys env ty1args ty2args } unify_tys :: UMEnv -> [Type] -> [Type] -> UM () +-- Precondition: see (Unification Kind Invariant) unify_tys env orig_xs orig_ys = go orig_xs orig_ys where @@ -1260,8 +1213,7 @@ uUnrefined :: UMEnv -- We know that tv1 isn't refined uUnrefined env tv1' ty2 ty2' kco - -- Use tcView, not coreView. See Note [coreView vs tcView] in GHC.Core.Type. - | Just ty2'' <- tcView ty2' + | Just ty2'' <- coreView ty2' = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms -- This is essential, in case we have -- type Foo a = a @@ -1555,8 +1507,6 @@ ty_co_match :: MatchEnv -- ^ ambient helpful info -- where lsubst = lcSubstLeft(env) and rsubst = lcSubstRight(env) ty_co_match menv subst ty co lkco rkco | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco - -- why coreView here, not tcView? Because we're firmly after type-checking. - -- This function is used only during coercion optimisation. -- handle Refl case: | tyCoVarsOfType ty `isNotInDomainOf` subst @@ -1615,24 +1565,24 @@ ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 -- yes, the one from Type, not TcType; this is for coercion optimization = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco = ty_co_match_tc menv subst tc1 tys tc2 cos -ty_co_match menv subst (FunTy _ w ty1 ty2) co _lkco _rkco - | Just (tc, [co_mult,rrco1,rrco2,co1,co2]) <- splitTyConAppCo_maybe co - , tc == funTyCon - = let rr1 = getRuntimeRep ty1 - rr2 = getRuntimeRep ty2 - Pair lkcos rkcos = traverse (fmap (mkNomReflCo . typeKind) . coercionKind) - [co_mult,rrco1, rrco2,co1,co2] - in -- NB: we include the RuntimeRep arguments in the matching; not doing so caused #21205. - ty_co_match_args menv subst - [w, rr1, rr2, ty1, ty2] - [co_mult, rrco1, rrco2, co1, co2] - lkcos rkcos + +ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 }) + (FunCo { fco_mult = co_w, fco_arg = co1, fco_res = co2 }) _lkco _rkco + = ty_co_match_args menv subst [w, rep1, rep2, ty1, ty2] + [co_w, co1_rep, co2_rep, co1, co2] + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + co1_rep = mkRuntimeRepCo co1 + co2_rep = mkRuntimeRepCo co2 + -- NB: we include the RuntimeRep arguments in the matching; + -- not doing so caused #21205. ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) (ForAllCo tv2 kind_co2 co2) @@ -1655,9 +1605,9 @@ ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) -- 1. Given: -- cv1 :: (s1 :: k1) ~r (s2 :: k2) -- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) --- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) +-- eta1 = mkSelCo (SelTyCon 2 role) (downgradeRole r Nominal kind_co2) -- :: s1' ~ t1 --- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) +-- eta2 = mkSelCo (SelTyCon 3 role) (downgradeRole r Nominal kind_co2) -- :: s2' ~ t2 -- Wanted: -- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 @@ -1687,7 +1637,6 @@ ty_co_match menv subst ty co1 lkco rkco in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') (rkco `mkTransCo` kco') - ty_co_match menv subst ty co lkco rkco | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco | otherwise = Nothing @@ -1698,16 +1647,13 @@ ty_co_match_tc :: MatchEnv -> LiftCoEnv -> Maybe LiftCoEnv ty_co_match_tc menv subst tc1 tys1 tc2 cos2 = do { guard (tc1 == tc2) - ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } - where - Pair lkcos rkcos - = traverse (fmap (mkNomReflCo . typeKind) . coercionKind) cos2 + ; ty_co_match_args menv subst tys1 cos2 } ty_co_match_app :: MatchEnv -> LiftCoEnv -> Type -> [Type] -> Coercion -> [Coercion] -> Maybe LiftCoEnv ty_co_match_app menv subst ty1 ty1args co2 co2args - | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 + | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 , Just (co2', co2a) <- splitAppCo_maybe co2 = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) @@ -1715,32 +1661,30 @@ ty_co_match_app menv subst ty1 ty1args co2 co2args = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco - ; let Pair lkcos rkcos = traverse (fmap (mkNomReflCo . typeKind) . coercionKind) co2args - ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } + ; ty_co_match_args menv subst2 ty1args co2args } where ki1 = typeKind ty1 ki2 = promoteCoercion co2 ki_ki_co = mkNomReflCo liftedTypeKind -ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] - -> [Coercion] -> [Coercion] -> [Coercion] +ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] -> Maybe LiftCoEnv -ty_co_match_args _ subst [] [] _ _ = Just subst -ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) - = do { subst' <- ty_co_match menv subst ty arg lkco rkco - ; ty_co_match_args menv subst' tys args lkcos rkcos } -ty_co_match_args _ _ _ _ _ _ = Nothing +ty_co_match_args menv subst (ty:tys) (arg:args) + = do { let Pair lty rty = coercionKind arg + lkco = mkNomReflCo (typeKind lty) + rkco = mkNomReflCo (typeKind rty) + ; subst' <- ty_co_match menv subst ty arg lkco rkco + ; ty_co_match_args menv subst' tys args } +ty_co_match_args _ subst [] [] = Just subst +ty_co_match_args _ _ _ _ = Nothing pushRefl :: Coercion -> Maybe Coercion pushRefl co = case (isReflCo_maybe co) of Just (AppTy ty1 ty2, Nominal) -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) - Just (FunTy _ w ty1 ty2, r) - | Just rep1 <- getRuntimeRep_maybe ty1 - , Just rep2 <- getRuntimeRep_maybe ty2 - -> Just (TyConAppCo r funTyCon [ multToCo w, mkReflCo r rep1, mkReflCo r rep2 - , mkReflCo r ty1, mkReflCo r ty2 ]) + Just (FunTy af w ty1 ty2, r) + -> Just (FunCo r af af (mkReflCo r w) (mkReflCo r ty1) (mkReflCo r ty2)) Just (TyConApp tc tys, r) -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys)) Just (ForAllTy (Bndr tv _) ty, r) @@ -2065,3 +2009,4 @@ mkFlattenFreshCoVar in_scope kind = let uniq = unsafeGetFreshLocalUnique in_scope name = mkSystemVarName uniq (fsLit "flc") in mkCoVar name kind + diff --git a/compiler/GHC/Core/UsageEnv.hs b/compiler/GHC/Core/UsageEnv.hs index b8a6dd1468..3f28178fe2 100644 --- a/compiler/GHC/Core/UsageEnv.hs +++ b/compiler/GHC/Core/UsageEnv.hs @@ -46,10 +46,10 @@ addUsage x Bottom = x addUsage (MUsage x) (MUsage y) = MUsage $ mkMultAdd x y scaleUsage :: Mult -> Usage -> Usage -scaleUsage One Bottom = Bottom -scaleUsage _ Zero = Zero -scaleUsage x Bottom = MUsage x -scaleUsage x (MUsage y) = MUsage $ mkMultMul x y +scaleUsage OneTy Bottom = Bottom +scaleUsage _ Zero = Zero +scaleUsage x Bottom = MUsage x +scaleUsage x (MUsage y) = MUsage $ mkMultMul x y -- For now, we use extra multiplicity Bottom for empty case. data UsageEnv = UsageEnv !(NameEnv Mult) Bool @@ -67,19 +67,19 @@ addUE (UsageEnv e1 b1) (UsageEnv e2 b2) = UsageEnv (plusNameEnv_C mkMultAdd e1 e2) (b1 || b2) scaleUE :: Mult -> UsageEnv -> UsageEnv -scaleUE One ue = ue +scaleUE OneTy ue = ue scaleUE w (UsageEnv e _) = UsageEnv (mapNameEnv (mkMultMul w) e) False supUE :: UsageEnv -> UsageEnv -> UsageEnv supUE (UsageEnv e1 False) (UsageEnv e2 False) = - UsageEnv (plusNameEnv_CD mkMultSup e1 Many e2 Many) False + UsageEnv (plusNameEnv_CD mkMultSup e1 ManyTy e2 ManyTy) False supUE (UsageEnv e1 b1) (UsageEnv e2 b2) = UsageEnv (plusNameEnv_CD2 combineUsage e1 e2) (b1 && b2) where combineUsage (Just x) (Just y) = mkMultSup x y combineUsage Nothing (Just x) | b1 = x - | otherwise = Many + | otherwise = ManyTy combineUsage (Just x) Nothing | b2 = x - | otherwise = Many + | otherwise = ManyTy combineUsage Nothing Nothing = pprPanic "supUE" (ppr e1 <+> ppr e2) -- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well. diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index bbce904167..3f3ef30a14 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -73,7 +73,7 @@ import GHC.Core.Ppr import GHC.Core.DataCon import GHC.Core.Type as Type import GHC.Core.FamInstEnv -import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) +import GHC.Core.TyCo.Compare( eqType, eqTypeX ) import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.TyCon @@ -169,26 +169,15 @@ mkLamTypes :: [Var] -> Type -> Type mkLamType v body_ty | isTyVar v - = mkForAllTy v Inferred body_ty + = mkForAllTy (Bndr v Inferred) body_ty | isCoVar v , v `elemVarSet` tyCoVarsOfType body_ty - = mkForAllTy v Required body_ty + = mkForAllTy (Bndr v Required) body_ty | otherwise = mkFunctionType (varMult v) (varType v) body_ty -mkFunctionType :: Mult -> Type -> Type -> Type --- This one works out the AnonArgFlag from the argument type --- See GHC.Types.Var Note [AnonArgFlag] -mkFunctionType mult arg_ty res_ty - | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag] - = assert (eqType mult Many) $ - mkInvisFunTy mult arg_ty res_ty - - | otherwise - = mkVisFunTy mult arg_ty res_ty - mkLamTypes vs ty = foldr mkLamType ty vs {- @@ -238,7 +227,7 @@ applyTypeToArgs pp_e op_ty args go op_ty [] = op_ty go op_ty (Type ty : args) = go_ty_args op_ty [ty] args go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args - go op_ty (_ : args) | Just (_, _, res_ty) <- splitFunTy_maybe op_ty + go op_ty (_ : args) | Just (_, _, _, res_ty) <- splitFunTy_maybe op_ty = go res_ty args go _ args = pprPanic "applyTypeToArgs" (panic_msg args) @@ -1400,9 +1389,8 @@ isExpandableApp fn n_val_args | Just (bndr, ty) <- splitPiTy_maybe ty = case bndr of - Named {} -> all_pred_args n_val_args ty - Anon InvisArg _ -> all_pred_args (n_val_args-1) ty - Anon VisArg _ -> False + Named {} -> all_pred_args n_val_args ty + Anon _ af -> isInvisibleFunArg af && all_pred_args (n_val_args-1) ty | otherwise = False @@ -1635,9 +1623,9 @@ app_ok fun_ok primop_ok fun args (arg_tys, _) = splitPiTys (idType fun) -- Used for arguments to primops and to partial applications - arg_ok :: TyBinder -> CoreExpr -> Bool + arg_ok :: PiTyVarBinder -> CoreExpr -> Bool arg_ok (Named _) _ = True -- A type argument - arg_ok (Anon _ ty) arg -- A term argument + arg_ok (Anon ty _) arg -- A term argument | Just Lifted <- typeLevity_maybe (scaledThing ty) = True -- See Note [Primops with lifted arguments] | otherwise diff --git a/compiler/GHC/Core/Utils.hs-boot b/compiler/GHC/Core/Utils.hs-boot deleted file mode 100644 index 6dab0d5963..0000000000 --- a/compiler/GHC/Core/Utils.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module GHC.Core.Utils where - -import GHC.Core.Multiplicity -import GHC.Core.Type - -mkFunctionType :: Mult -> Type -> Type -> Type diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index c8471039e7..88a450e3df 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -9,7 +9,7 @@ module GHC.CoreToIface , toIfaceBndr , toIfaceTopBndr , toIfaceForAllBndr - , toIfaceTyCoVarBinders + , toIfaceForAllBndrs , toIfaceTyVar -- * Types , toIfaceType, toIfaceTypeX @@ -57,18 +57,18 @@ import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.PatSyn import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCo.Tidy ( tidyCo ) import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.Types ( heqTyCon ) -import GHC.Builtin.Names import GHC.Iface.Syntax import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Types.Id.Make ( noinlineIdName ) +import GHC.Types.Id.Make ( noinlineIdName, noinlineConstraintIdName ) import GHC.Types.Literal import GHC.Types.Name import GHC.Types.Basic @@ -83,7 +83,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import Data.Maybe ( catMaybes ) +import Data.Maybe ( isNothing, catMaybes ) {- Note [Avoiding space leaks in toIface*] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -143,11 +143,14 @@ toIfaceBndrX fr var | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) -toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis -toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis +toIfaceForAllBndrs :: [VarBndr TyCoVar vis] -> [VarBndr IfaceBndr vis] +toIfaceForAllBndrs = map toIfaceForAllBndr -toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis] -toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder +toIfaceForAllBndr :: VarBndr TyCoVar flag -> VarBndr IfaceBndr flag +toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet + +toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) +toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis {- ************************************************************************ @@ -217,12 +220,6 @@ toIfaceTyVar = occNameFS . getOccName toIfaceCoVar :: CoVar -> FastString toIfaceCoVar = occNameFS . getOccName -toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) -toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet - -toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) -toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis - ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc @@ -290,7 +287,7 @@ toIfaceCoercionX fr co go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) go (SymCo co) = IfaceSymCo (go co) go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) - go (NthCo _r d co) = IfaceNthCo d (go co) + go (SelCo d co) = IfaceSelCo d (go co) go (LRCo lr co) = IfaceLRCo lr (go co) go (InstCo co arg) = IfaceInstCo (go co) (go arg) go (KindCo c) = IfaceKindCo (go c) @@ -300,12 +297,12 @@ toIfaceCoercionX fr co go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) - go (TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [_,_,_,_, _] <- cos = panic "toIfaceCoercion" - | otherwise = - IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) - go (FunCo r w co1 co2) = IfaceFunCo r (go w) (go co1) (go co2) + go co@(TyConAppCo r tc cos) + = assertPpr (isNothing (tyConAppFunCo_maybe r tc cos)) (ppr co) $ + IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) + + go (FunCo { fco_role = r, fco_mult = w, fco_arg = co1, fco_res = co2 }) + = IfaceFunCo r (go w) (go co1) (go co2) go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) (toIfaceCoercionX fr' k) @@ -338,6 +335,9 @@ toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs -- Is 'blib' visible? It depends on the visibility flag on j, -- so we have to substitute for k. Annoying! toIfaceAppArgsX fr kind ty_args + | null ty_args + = IA_Nil + | otherwise = go (mkEmptySubst in_scope) kind ty_args where in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) @@ -355,11 +355,10 @@ toIfaceAppArgsX fr kind ty_args go env (FunTy { ft_af = af, ft_res = res }) (t:ts) = IA_Arg (toIfaceTypeX fr t) argf (go env res ts) where - argf = case af of - VisArg -> Required - InvisArg -> Inferred - -- It's rare for a kind to have a constraint argument, but - -- it can happen. See Note [AnonTCB InvisArg] in GHC.Core.TyCon. + argf | isVisibleFunArg af = Required + | otherwise = Inferred + -- It's rare for a kind to have a constraint argument, but it + -- can happen. See Note [AnonTCB with constraint arg] in GHC.Core.TyCon. go env ty ts@(t1:ts1) | not (isEmptyTCvSubst env) @@ -410,8 +409,8 @@ patSynToIfaceDecl ps (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps univ_bndrs = patSynUnivTyVarBinders ps ex_bndrs = patSynExTyVarBinders ps - (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs - (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs + (env1, univ_bndrs') = tidyForAllTyBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyForAllTyBinders env1 ex_bndrs to_if_pr (name, _type, needs_dummy) = (name, needs_dummy) {- @@ -548,7 +547,7 @@ toIfGuidance src guidance toIfaceExpr :: CoreExpr -> IfaceExpr toIfaceExpr (Var v) = toIfaceVar v -toIfaceExpr (Lit (LitRubbish r)) = IfaceLitRubbish (toIfaceType r) +toIfaceExpr (Lit (LitRubbish tc r)) = IfaceLitRubbish tc (toIfaceType r) toIfaceExpr (Lit l) = IfaceLit l toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) @@ -646,8 +645,8 @@ toIfaceVar :: Id -> IfaceExpr toIfaceVar v | isBootUnfolding (idUnfolding v) = -- See Note [Inlining and hs-boot files] - IfaceApp (IfaceApp (IfaceExt noinlineIdName) - (IfaceType (toIfaceType (idType v)))) + IfaceApp (IfaceApp (IfaceExt noinline_id) + (IfaceType (toIfaceType ty))) (IfaceExt name) -- don't use mkIfaceApps, or infinite loop | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) @@ -655,7 +654,12 @@ toIfaceVar v | isExternalName name = IfaceExt name | otherwise = IfaceLcl (getOccFS name) - where name = idName v + where + name = idName v + ty = idType v + noinline_id | isConstraintKind (typeKind ty) = noinlineConstraintIdName + | otherwise = noinlineIdName + --------------------- @@ -734,7 +738,8 @@ But how do we arrange for this to happen? There are two ingredients: 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), for every variable reference we see if we are referring to an 'Id' that came from an hs-boot file. If so, we add a `noinline` - to the reference. + to the reference. See Note [noinlineId magic] + in GHC.Types.Id.Make 2. But how do we know if a reference came from an hs-boot file or not? We could record this directly in the 'IdInfo', but diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot index a906414aaf..61b291f324 100644 --- a/compiler/GHC/CoreToIface.hs-boot +++ b/compiler/GHC/CoreToIface.hs-boot @@ -11,7 +11,7 @@ import GHC.Types.Var.Set( VarSet ) -- For GHC.Core.TyCo.Rep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) +toIfaceForAllBndrs :: [VarBndr TyCoVar flag] -> [VarBndr IfaceBndr flag] toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index cd1753499a..d70d8acc65 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -38,7 +38,7 @@ import GHC.Types.CostCentre import GHC.Types.Tickish import GHC.Types.Var.Env import GHC.Types.Name ( isExternalName, nameModule_maybe ) -import GHC.Types.Basic ( Arity ) +import GHC.Types.Basic ( Arity, TypeOrConstraint(..) ) import GHC.Types.Literal import GHC.Types.ForeignCall import GHC.Types.IPE @@ -404,7 +404,7 @@ coreToStgExpr expr@(App _ _) -- Recompute representation, because in -- '(RUBBISH[rep] x) :: (T :: TYPE rep2)' -- rep might not be equal to rep2 - -> return (StgLit $ LitRubbish $ getRuntimeRep (exprType expr)) + -> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep (exprType expr)) _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr) where @@ -494,8 +494,7 @@ mkStgAltType bndr alts prim_reps = typePrimRep bndr_ty _is_poly_alt_tycon tc - = isFunTyCon tc - || isPrimTyCon tc -- "Any" is lifted but primitive + = isPrimTyCon tc -- "Any" is lifted but primitive || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict -- function application where argument has a -- type-family type diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 9ca8bff0c9..6254f21548 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -1046,7 +1046,8 @@ cpeApp top_env expr cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make - || f `hasKey` noinlineIdKey -- Replace (noinline a) with a + || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey + -- Replace (noinline a) with a -- See Note [noinlineId magic] in GHC.Types.Id.Make || f `hasKey` nospecIdKey -- Replace (nospec a) with a -- See Note [nospecId magic] in GHC.Types.Id.Make @@ -2204,7 +2205,7 @@ fiddleCCall id newVar :: Type -> UniqSM Id newVar ty - = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") Many ty + = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") ManyTy ty ------------------------------------------------------------------------------ diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs index 91239ab1d5..371d8f545d 100644 --- a/compiler/GHC/Data/Graph/UnVar.hs +++ b/compiler/GHC/Data/Graph/UnVar.hs @@ -16,7 +16,7 @@ equal to g, but twice as expensive and large. -} module GHC.Data.Graph.UnVar ( UnVarSet - , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets + , emptyUnVarSet, mkUnVarSet, unionUnVarSet, unionUnVarSets , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList , elemUnVarSet, isEmptyUnVarSet , UnVarGraph @@ -26,13 +26,13 @@ module GHC.Data.Graph.UnVar , neighbors , hasLoopAt , delNode + , domUFMUnVarSet ) where import GHC.Prelude -import GHC.Types.Id -import GHC.Types.Var.Env -import GHC.Types.Unique.FM +import GHC.Types.Unique.FM( UniqFM, ufmToSet_Directly ) +import GHC.Types.Var import GHC.Utils.Outputable import GHC.Types.Unique @@ -50,6 +50,9 @@ newtype UnVarSet = UnVarSet (S.IntSet) k :: Var -> Int k v = getKey (getUnique v) +domUFMUnVarSet :: UniqFM key elt -> UnVarSet +domUFMUnVarSet ae = UnVarSet $ ufmToSet_Directly ae + emptyUnVarSet :: UnVarSet emptyUnVarSet = UnVarSet S.empty @@ -75,9 +78,6 @@ sizeUnVarSet (UnVarSet s) = S.size s mkUnVarSet :: [Var] -> UnVarSet mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs -varEnvDom :: VarEnv a -> UnVarSet -varEnvDom ae = UnVarSet $ ufmToSet_Directly ae - extendUnVarSet :: Var -> UnVarSet -> UnVarSet extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 0eb6f9e89c..5ca7487c27 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -2120,7 +2120,7 @@ myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do binding for the stg2stg step) -} let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") (mkPseudoUniqueE 0) - Many + ManyTy (exprType prepd_expr) (stg_binds, prov_map, collected_ccs, stg_cg_infos) <- myCoreToStg logger diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index a0c588413b..41dd33bee9 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -388,11 +388,7 @@ deriving instance Data (HsUntypedSplice GhcPs) deriving instance Data (HsUntypedSplice GhcRn) deriving instance Data (HsUntypedSplice GhcTc) -deriving instance Data (HsUntypedSpliceResult (HsExpr GhcRn)) - -deriving instance Data (HsUntypedSpliceResult (Pat GhcRn)) - -deriving instance Data (HsUntypedSpliceResult (HsType GhcRn)) +deriving instance Data a => Data (HsUntypedSpliceResult a) -- deriving instance (DataIdLR p p) => Data (HsQuote p) deriving instance Data (HsQuote GhcPs) diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs index 2e40cec8d0..6310a0f3c9 100644 --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -21,10 +21,10 @@ import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.TyCo.Rep import GHC.Core.Type -import GHC.Core.Utils import GHC.Hs import GHC.Tc.Types.Evidence import GHC.Types.Id +import GHC.Types.Var( VarBndr(..) ) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -182,9 +182,9 @@ hsWrapperType wrap ty = prTypeType $ go wrap (ty,[]) exp_res = hsWrapperType w2 act_res in mkFunctionType m exp_arg exp_res go (WpCast co) = liftPRType $ \_ -> coercionRKind co - go (WpEvLam v) = liftPRType $ mkInvisFunTyMany (idType v) + go (WpEvLam v) = liftPRType $ mkInvisFunTy (idType v) go (WpEvApp _) = liftPRType $ funResultTy - go (WpTyLam tv) = liftPRType $ mkForAllTy tv Inferred + go (WpTyLam tv) = liftPRType $ mkForAllTy (Bndr tv Inferred) go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas) go (WpLet _) = id go (WpMultCoercion _) = id @@ -193,7 +193,7 @@ lhsCmdTopType :: LHsCmdTop GhcTc -> Type lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty matchGroupTcType :: MatchGroupTc -> Type -matchGroupTcType (MatchGroupTc args res _) = mkVisFunTys args res +matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res syntaxExprType :: SyntaxExpr GhcTc -> Type syntaxExprType (SyntaxExprTc e _ _) = hsExprType e diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 5e614ff79d..9004f8dacb 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -104,12 +104,12 @@ import GHC.Types.Id ( Id ) import GHC.Types.SourceText import GHC.Types.Name( Name, NamedThing(getName), tcName ) import GHC.Types.Name.Reader ( RdrName ) -import GHC.Types.Var ( VarBndr ) +import GHC.Types.Var ( VarBndr, visArgTypeLike ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr ) import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type -import GHC.Iface.Type +import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) import GHC.Hs.Doc import GHC.Types.Basic import GHC.Types.SrcLoc @@ -315,7 +315,7 @@ type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn] type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives type instance XSpliceTy GhcPs = NoExtField -type instance XSpliceTy GhcRn = HsUntypedSpliceResult (HsType GhcRn) +type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn) type instance XSpliceTy GhcTc = Kind type instance XDocTy (GhcPass _) = EpAnn [AddEpAnn] @@ -384,9 +384,9 @@ instance -- See #18846 pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc -pprHsArrow (HsUnrestrictedArrow _) = arrow -pprHsArrow (HsLinearArrow _) = lollipop -pprHsArrow (HsExplicitMult _ p _) = mulArrow (const ppr) p +pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left False) +pprHsArrow (HsLinearArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left True) +pprHsArrow (HsExplicitMult _ p _) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p)) type instance XConDeclField (GhcPass _) = EpAnn [AddEpAnn] type instance XXConDeclField (GhcPass _) = DataConCantHappen diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 6e8814321c..8e934d7c29 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -55,10 +55,6 @@ module GHC.Hs.Utils( mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkLocatedList, - -- * Constructing general big tuples - -- $big_tuples - mkChunkified, chunkify, - -- * Bindings mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind, mkPatSynBind, @@ -122,12 +118,16 @@ import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Tc.Types.Evidence -import GHC.Core.TyCo.Rep -import GHC.Core.Multiplicity ( pattern Many ) -import GHC.Builtin.Types ( unitTy ) -import GHC.Tc.Utils.TcType + +import GHC.Core.Coercion( isReflCo ) +import GHC.Core.Multiplicity ( pattern ManyTy ) import GHC.Core.DataCon import GHC.Core.ConLike +import GHC.Core.Make ( mkChunkified ) +import GHC.Core.Type ( Type, isUnliftedType ) + +import GHC.Builtin.Types ( unitTy ) + import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Set hiding ( unitFV ) @@ -138,9 +138,9 @@ import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Types.Fixity import GHC.Types.SourceText + import GHC.Data.FastString import GHC.Data.Bag -import GHC.Settings.Constants import GHC.Utils.Misc import GHC.Utils.Outputable @@ -268,7 +268,7 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars - <.> mkWpLams dicts) expr + <.> mkWpEvLams dicts) expr -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking @@ -414,7 +414,7 @@ mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, xbstc_boundResultType = unitTy, -- unitTy is a dummy value -- can't panic here: it's forced during zonking - xbstc_boundResultMult = Many, + xbstc_boundResultMult = ManyTy, xbstc_failOp = Nothing }) pat body emptyRecStmt' :: forall idL idR body . @@ -681,47 +681,6 @@ mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkBigLHsPatTup = mkChunkified mkLHsPatTup --- $big_tuples --- #big_tuples# --- --- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but --- we might conceivably want to build such a massive tuple as part of the --- output of a desugaring stage (notably that for list comprehensions). --- --- We call tuples above this size \"big tuples\", and emulate them by --- creating and pattern matching on >nested< tuples that are expressible --- by GHC. --- --- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) --- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any --- construction to be big. --- --- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' --- and 'mkTupleCase' functions to do all your work with tuples you should be --- fine, and not have to worry about the arity limitation at all. - --- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition -mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' - -> [a] -- ^ Possible \"big\" list of things to construct from - -> a -- ^ Constructed thing made possible by recursive decomposition -mkChunkified small_tuple as = mk_big_tuple (chunkify as) - where - -- Each sub-list is short enough to fit in a tuple - mk_big_tuple [as] = small_tuple as - mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) - -chunkify :: [a] -> [[a]] --- ^ Split a list into lists that are small enough to have a corresponding --- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' --- But there may be more than 'mAX_TUPLE_SIZE' sub-lists -chunkify xs - | n_xs <= mAX_TUPLE_SIZE = [xs] - | otherwise = split xs - where - n_xs = length xs - split [] = [] - split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) - {- ************************************************************************ * * @@ -815,7 +774,7 @@ mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = XPat $ CoPat co_fn p ty mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc -mkHsWrapPatCo co pat ty | isTcReflCo co = pat +mkHsWrapPatCo co pat ty | isReflCo co = pat | otherwise = XPat $ CoPat (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 6da39a27bc..3a3128489c 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -45,7 +45,8 @@ import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances ) import GHC.Tc.Module ( runTcInteractive ) import GHC.Core.Type -import GHC.Core.TyCon ( tyConDataCons ) +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCon ( tyConDataCons ) import GHC.Core import GHC.Core.FVs ( exprsSomeFreeVarsList ) import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) @@ -746,11 +747,11 @@ mkUnsafeCoercePrimPair _old_id old_expr , openAlphaTyVar, openBetaTyVar , x ] $ mkSingleAltCase scrut1 - (mkWildValBinder Many scrut1_ty) + (mkWildValBinder ManyTy scrut1_ty) (DataAlt unsafe_refl_data_con) [rr_cv] $ mkSingleAltCase scrut2 - (mkWildValBinder Many scrut2_ty) + (mkWildValBinder ManyTy scrut2_ty) (DataAlt unsafe_refl_data_con) [ab_cv] $ Var x `mkCast` x_co diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index e7dbebb5f9..a761440fc7 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -87,7 +87,7 @@ mkCmdEnv tc_meths where mk_bind (std_name, expr) = do { rhs <- dsExpr expr - ; id <- newSysLocalDs Many (exprType rhs) + ; id <- newSysLocalDs ManyTy (exprType rhs) -- no check needed; these are functions ; return (NonRec id rhs, (std_name, id)) } @@ -136,18 +136,18 @@ do_premap ids b_ty c_ty d_ty f g -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a mkFstExpr :: Type -> Type -> DsM CoreExpr mkFstExpr a_ty b_ty = do - a_var <- newSysLocalDs Many a_ty - b_var <- newSysLocalDs Many b_ty - pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) + a_var <- newSysLocalDs ManyTy a_ty + b_var <- newSysLocalDs ManyTy b_ty + pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty) return (Lam pair_var (coreCasePair pair_var a_var b_var (Var a_var))) -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b mkSndExpr :: Type -> Type -> DsM CoreExpr mkSndExpr a_ty b_ty = do - a_var <- newSysLocalDs Many a_ty - b_var <- newSysLocalDs Many b_ty - pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) + a_var <- newSysLocalDs ManyTy a_ty + b_var <- newSysLocalDs ManyTy b_ty + pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty) return (Lam pair_var (coreCasePair pair_var a_var b_var (Var b_var))) @@ -162,7 +162,7 @@ because the list of variables is typically not yet defined. coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr coreCaseTuple uniqs scrut_var vars body - = mkTupleCase uniqs vars body scrut_var (Var scrut_var) + = mkBigTupleCase uniqs vars body (Var scrut_var) coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body @@ -178,10 +178,19 @@ mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] mkCoreUnitExpr :: CoreExpr mkCoreUnitExpr = mkCoreTup [] -{- -The input is divided into a local environment, which is a flat tuple -(unless it's too big), and a stack, which is a right-nested pair. -In general, the input has the form +{- Note [Environment and stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The input is divided into + +* A local environment, which is a flat tuple (unless it's too big) + The elements of the local environment can be + - of kind Type (for ordinary variables), or + - of kind Constraint (for dictionaries bound by patterns) + +* A stack, which is a right-nested pair. + The elements on the stack are always of kind Type. + +So in general, the input has the form ((x1,...,xn), (s1,...(sk,())...)) @@ -225,9 +234,9 @@ matchEnvStack :: [Id] -- x1..xn -> DsM CoreExpr matchEnvStack env_ids stack_id body = do uniqs <- newUniqueSupply - tup_var <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) + tup_var <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) let match_env = coreCaseTuple uniqs tup_var env_ids body - pair_id <- newSysLocalDs Many (mkCorePairTy (idType tup_var) (idType stack_id)) + pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id)) return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) ---------------------------------------------- @@ -244,7 +253,7 @@ matchEnv :: [Id] -- x1..xn -> DsM CoreExpr matchEnv env_ids body = do uniqs <- newUniqueSupply - tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) + tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) ---------------------------------------------- @@ -259,7 +268,7 @@ matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) matchVarStack [] stack_id body = return (stack_id, body) matchVarStack (param_id:param_ids) stack_id body = do (tail_id, tail_code) <- matchVarStack param_ids stack_id body - pair_id <- newSysLocalDs Many (mkCorePairTy (idType param_id) (idType tail_id)) + pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType param_id) (idType tail_id)) return (pair_id, coreCasePair pair_id param_id tail_id tail_code) mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc @@ -288,7 +297,7 @@ dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do let env_stk_ty = mkCorePairTy env_ty unitTy let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty - var <- selectSimpleMatchVarL Many pat + var <- selectSimpleMatchVarL ManyTy pat match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr let pat_ty = hsLPatType pat let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty @@ -337,7 +346,7 @@ dsCmd ids local_vars stack_ty res_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty core_make_arg <- matchEnvStack env_ids stack_id core_arg return (do_premap ids (envStackType env_ids stack_ty) @@ -363,7 +372,7 @@ dsCmd ids local_vars stack_ty res_ty core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty core_make_pair <- matchEnvStack env_ids stack_id (mkCorePairExpr core_arrow core_arg) @@ -390,8 +399,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do stack_ty' = mkCorePairTy arg_ty stack_ty (core_cmd, free_vars, env_ids') <- dsfixCmd ids local_vars stack_ty' res_ty cmd - stack_id <- newSysLocalDs Many stack_ty - arg_id <- newSysLocalDs Many arg_ty + stack_id <- newSysLocalDs ManyTy stack_ty + arg_id <- newSysLocalDs ManyTy arg_ty -- push the argument expression onto the stack let stack' = mkCorePairExpr (Var arg_id) (Var stack_id) @@ -436,7 +445,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty either_con <- dsLookupTyCon eitherTyConName left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName @@ -498,7 +507,7 @@ case bodies, containing the following fields: -} dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty (match', core_choices) <- dsCases ids local_vars stack_id stack_ty res_ty match let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match' @@ -540,7 +549,7 @@ dsCmd ids local_vars stack_ty res_ty -- construct and desugar a case expression with multiple scrutinees (core_body, free_vars, env_ids') <- trimInput \env_ids -> do - stack_id <- newSysLocalDs Many stack_ty' + stack_id <- newSysLocalDs ManyTy stack_ty' (match', core_choices) <- dsCases ids local_vars' stack_id stack_ty' res_ty match @@ -556,8 +565,8 @@ dsCmd ids local_vars stack_ty res_ty return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars') - param_ids <- mapM (newSysLocalDs Many) pat_tys - stack_id' <- newSysLocalDs Many stack_ty' + param_ids <- mapM (newSysLocalDs ManyTy) pat_tys + stack_id' <- newSysLocalDs ManyTy stack_ty' -- the expression is built from the inside out, so the actions -- are presented in reverse order @@ -592,7 +601,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds@binds _ body) env_ids (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty -- build a new environment, plus the stack, using the let bindings core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) -- match the old environment and stack against the input @@ -658,7 +667,7 @@ dsTrimCmdArg local_vars env_ids (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) let @@ -722,8 +731,8 @@ dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body - param_ids <- mapM (newSysLocalDs Many) pat_tys - stack_id' <- newSysLocalDs Many stack_ty' + param_ids <- mapM (newSysLocalDs ManyTy) pat_tys + stack_id' <- newSysLocalDs ManyTy stack_ty' -- the expression is built from the inside out, so the actions -- are presented in reverse order @@ -805,7 +814,7 @@ dsCases ids local_vars stack_id stack_ty res_ty Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$> dsExpr (HsLamCase EpAnnNotUsed LamCase (MG { mg_alts = noLocA [] - , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty Generated + , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty Generated })) -- Replace the commands in the case with these tagged tuples, @@ -847,7 +856,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids let env_ty = mkBigCoreVarTupTy env_ids - env_var <- newSysLocalDs Many env_ty + env_var <- newSysLocalDs ManyTy env_ty let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) return (do_premap ids env_ty @@ -949,7 +958,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do -- projection function -- \ (p, (xs2)) -> (zs) - env_id <- newSysLocalDs Many env_ty2 + env_id <- newSysLocalDs ManyTy env_ty2 uniqs <- newUniqueSupply let after_c_ty = mkCorePairTy pat_ty env_ty2 @@ -957,10 +966,10 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty - pat_id <- selectSimpleMatchVarL Many pat + pat_id <- selectSimpleMatchVarL ManyTy pat match_code <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr - pair_id <- newSysLocalDs Many after_c_ty + pair_id <- newSysLocalDs ManyTy after_c_ty let proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) @@ -1023,7 +1032,7 @@ dsCmdStmt ids local_vars out_ids -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) uniqs <- newUniqueSupply - env2_id <- newSysLocalDs Many env2_ty + env2_id <- newSysLocalDs ManyTy env2_ty let later_ty = mkBigCoreVarTupTy later_ids post_pair_ty = mkCorePairTy later_ty env2_ty @@ -1110,7 +1119,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) - rec_id <- newSysLocalDs Many rec_ty + rec_id <- newSysLocalDs ManyTy rec_ty let env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set env1_ids = dVarSetElems env1_id_set @@ -1120,7 +1129,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do where selectVar v | v `elemVarSet` rec_id_set - = mkTupleSelector rec_ids v rec_id (Var rec_id) + = mkBigTupleSelector rec_ids v rec_id (Var rec_id) | otherwise = Var v squash_pair_fn <- matchEnvStack env1_ids rec_id core_body diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 683b998ad1..c33b753d07 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -54,6 +54,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity import GHC.Core.Rules +import GHC.Core.TyCo.Compare( eqType ) import GHC.Builtin.Names import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy ) @@ -298,7 +299,7 @@ dsAbsBinds dflags tyvars dicts exports mkLet aux_binds $ tup_expr - ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs) + ; poly_tup_id <- newSysLocalDs ManyTy (exprType poly_tup_rhs) -- Find corresponding global or make up a new one: sometimes -- we need to make new export to desugar strict binds, see @@ -309,10 +310,10 @@ dsAbsBinds dflags tyvars dicts exports , abe_poly = global , abe_mono = local, abe_prags = spec_prags }) -- See Note [AbsBinds wrappers] in "GHC.Hs.Binds" - = do { tup_id <- newSysLocalDs Many tup_ty + = do { tup_id <- newSysLocalDs ManyTy tup_ty ; core_wrap <- dsHsWrapper wrap ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ - mkTupleSelector all_locals local tup_id $ + mkBigTupleSelector all_locals local tup_id $ mkVarApps (Var poly_tup_id) (tyvars ++ dicts) rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags @@ -369,7 +370,7 @@ dsAbsBinds dflags tyvars dicts exports ([],[]) lcls mk_export local = - do global <- newSysLocalDs Many + do global <- newSysLocalDs ManyTy (exprType (mkLams tyvars (mkLams dicts (Var local)))) return (ABE { abe_poly = global , abe_mono = local @@ -715,7 +716,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; let fn_unf = realIdUnfolding poly_id simpl_opts = initSimpleOpts dflags spec_unf = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf - spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many. + spec_id = mkLocalId spec_name ManyTy spec_ty -- Specialised binding is toplevel, hence Many. `setInlinePragma` inl_prag `setIdUnfolding` spec_unf @@ -877,7 +878,7 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs = scopedSort unbound_tvs ++ unbound_dicts where unbound_tvs = [ v | v <- unbound_vars, isTyVar v ] - unbound_dicts = [ mkLocalId (localiseName (idName d)) Many (idType d) + unbound_dicts = [ mkLocalId (localiseName (idName d)) ManyTy (idType d) | d <- unbound_vars, isDictId d ] unbound_vars = [ v | v <- exprsFreeVarsList args , not (v `elemVarSet` orig_bndr_set) @@ -1269,7 +1270,7 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) } ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) - | Just (m,t1,t2) <- splitFunTy_maybe ty + | Just (_af,m,t1,t2) <- splitFunTy_maybe ty = do { e1 <- getRep ev1 t1 ; e2 <- getRep ev2 t2 ; em <- getRep evm m diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 65a83667a3..017263db9d 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -208,7 +208,7 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss eqn = EqnInfo { eqn_pats = [upat], eqn_orig = FromSource, eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar Many upat + ; var <- selectMatchVar ManyTy upat -- `var` will end up in a let binder, so the multiplicity -- doesn't matter. ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) @@ -715,7 +715,7 @@ dsDo ctx stmts ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts) ; let match_args (pat, fail_op) (vs,body) - = do { var <- selectSimpleMatchVarL Many pat + = do { var <- selectSimpleMatchVarL ManyTy pat ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat body_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure ctx pat match fail_op @@ -741,10 +741,10 @@ dsDo ctx stmts where new_bind_stmt = L loc $ BindStmt XBindStmtTc - { xbstc_bindOp = bind_op + { xbstc_bindOp = bind_op , xbstc_boundResultType = bind_ty - , xbstc_boundResultMult = Many - , xbstc_failOp = Nothing -- Tuple cannot fail + , xbstc_boundResultMult = ManyTy + , xbstc_failOp = Nothing -- Tuple cannot fail } (mkBigLHsPatTupId later_pats) mfix_app diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs index ed9137f99d..160e9acc97 100644 --- a/compiler/GHC/HsToCore/Foreign/C.hs +++ b/compiler/GHC/HsToCore/Foreign/C.hs @@ -81,7 +81,7 @@ dsCFExport fn_id co ext_name cconv isDyn = do let ty = coercionRKind co (bndrs, orig_res_ty) = tcSplitPiTys ty - fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs + fe_arg_tys' = mapMaybe anonPiTyBinderType_maybe bndrs -- We must use tcSplits here, because we want to see -- the (IO t) in the corner of the type! fe_arg_tys | isDyn = tail fe_arg_tys' @@ -189,7 +189,7 @@ dsCFExportDynamic id co0 cconv = do stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] export_ty = mkVisFunTyMany stable_ptr_ty arg_ty bindIOId <- dsLookupGlobalId bindIOName - stbl_value <- newSysLocalDs Many stable_ptr_ty + stbl_value <- newSysLocalDs ManyTy stable_ptr_ty (h_code, c_code, typestring, args_size) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True let {- @@ -316,7 +316,7 @@ dsFCall fn_id co fcall mDeclHeader = do tvs = map binderVar tv_bndrs the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) - work_id = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty + work_id = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty -- Build the wrapper work_app = mkApps (mkVarApps (Var work_id) tvs) val_args @@ -618,7 +618,7 @@ fun_type_arg_stdcall_info platform StdCallConv ty tyConUnique tc == funPtrTyConKey = let (bndrs, _) = tcSplitPiTys arg_ty - fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs + fe_arg_tys = mapMaybe anonPiTyBinderType_maybe bndrs in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys) fun_type_arg_stdcall_info _ _other_conv _ = Nothing diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index 6ffed05ee9..ee5c2a3b49 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -150,7 +150,7 @@ unboxArg arg tc `hasKey` boolTyConKey = do dflags <- getDynFlags let platform = targetPlatform dflags - prim_arg <- newSysLocalDs Many intPrimTy + prim_arg <- newSysLocalDs ManyTy intPrimTy return (Var prim_arg, \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) prim_arg @@ -162,8 +162,8 @@ unboxArg arg | is_product_type && data_con_arity == 1 = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $ -- Typechecker ensures this - do case_bndr <- newSysLocalDs Many arg_ty - prim_arg <- newSysLocalDs Many data_con_arg_ty1 + do case_bndr <- newSysLocalDs ManyTy arg_ty + prim_arg <- newSysLocalDs ManyTy data_con_arg_ty1 return (Var prim_arg, \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] ) @@ -177,7 +177,7 @@ unboxArg arg isJust maybe_arg3_tycon && (arg3_tycon == byteArrayPrimTyCon || arg3_tycon == mutableByteArrayPrimTyCon) - = do case_bndr <- newSysLocalDs Many arg_ty + = do case_bndr <- newSysLocalDs ManyTy arg_ty vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys) return (Var arr_cts_var, \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body] @@ -223,14 +223,11 @@ boxResult result_ty -- another case, and a coercion.) -- The result is IO t, so wrap the result in an IO constructor = do { res <- resultWrapper io_res_ty - ; let return_result state anss - = mkCoreUbxTup - [realWorldStatePrimTy, io_res_ty] - [state, anss] + ; let return_result state anss = mkCoreUnboxedTuple [state, anss] ; (ccall_res_ty, the_alt) <- mk_alt return_result res - ; state_id <- newSysLocalDs Many realWorldStatePrimTy + ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy ; let io_data_con = head (tyConDataCons io_tycon) toIOCon = dataConWrapId io_data_con @@ -266,7 +263,7 @@ mk_alt :: (Expr Var -> Expr Var -> Expr Var) -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result) = do -- The ccall returns () - state_id <- newSysLocalDs Many realWorldStatePrimTy + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy let the_rhs = return_result (Var state_id) (wrap_result (panic "boxResult")) @@ -280,8 +277,8 @@ mk_alt return_result (Just prim_res_ty, wrap_result) = -- The ccall returns a non-() value assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $ -- True because resultWrapper ensures it is so - do { result_id <- newSysLocalDs Many prim_res_ty - ; state_id <- newSysLocalDs Many realWorldStatePrimTy + do { result_id <- newSysLocalDs ManyTy prim_res_ty + ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy ; let the_rhs = return_result (Var state_id) (wrap_result (Var result_id)) ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs index 8ecf6c84ed..6ae6716685 100644 --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -129,7 +129,7 @@ matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do let upat = unLoc pat - match_var <- selectMatchVar Many upat + match_var <- selectMatchVar ManyTy upat -- We only allow unrestricted patterns in guard, hence the `Many` -- above. It isn't clear what linear patterns would mean, maybe we will -- figure it out in the future. diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 12a40e6c90..b9f7c664ce 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -366,8 +366,8 @@ dfBindComp c_id n_id (pat, core_list1) quals = do let b_ty = idType n_id -- create some new local id's - b <- newSysLocalDs Many b_ty - x <- newSysLocalDs Many x_ty + b <- newSysLocalDs ManyTy b_ty + x <- newSysLocalDs ManyTy x_ty -- build rest of the comprehension core_rest <- dfListComp c_id b quals @@ -397,11 +397,11 @@ mkZipBind :: [Type] -> DsM (Id, CoreExpr) -- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] mkZipBind elt_tys = do - ass <- mapM (newSysLocalDs Many) elt_list_tys - as' <- mapM (newSysLocalDs Many) elt_tys - as's <- mapM (newSysLocalDs Many) elt_list_tys + ass <- mapM (newSysLocalDs ManyTy) elt_list_tys + as' <- mapM (newSysLocalDs ManyTy) elt_tys + as's <- mapM (newSysLocalDs ManyTy) elt_list_tys - zip_fn <- newSysLocalDs Many zip_fn_ty + zip_fn <- newSysLocalDs ManyTy zip_fn_ty let inner_rhs = mkConsExpr elt_tuple_ty (mkBigCoreVarTup as') @@ -436,13 +436,13 @@ mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) mkUnzipBind ThenForm _ = return Nothing -- No unzipping for ThenForm mkUnzipBind _ elt_tys - = do { ax <- newSysLocalDs Many elt_tuple_ty - ; axs <- newSysLocalDs Many elt_list_tuple_ty - ; ys <- newSysLocalDs Many elt_tuple_list_ty - ; xs <- mapM (newSysLocalDs Many) elt_tys - ; xss <- mapM (newSysLocalDs Many) elt_list_tys + = do { ax <- newSysLocalDs ManyTy elt_tuple_ty + ; axs <- newSysLocalDs ManyTy elt_list_tuple_ty + ; ys <- newSysLocalDs ManyTy elt_tuple_list_ty + ; xs <- mapM (newSysLocalDs ManyTy) elt_tys + ; xss <- mapM (newSysLocalDs ManyTy) elt_list_tys - ; unzip_fn <- newSysLocalDs Many unzip_fn_ty + ; unzip_fn <- newSysLocalDs ManyTy unzip_fn_ty ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] @@ -450,8 +450,8 @@ mkUnzipBind _ elt_tys concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) tupled_concat_expression = mkBigCoreTup concat_expressions - folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) - folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) + folder_body_inner_case = mkBigTupleCase us1 xss tupled_concat_expression (Var axs) + folder_body_outer_case = mkBigTupleCase us2 xs folder_body_inner_case (Var ax) folder_body = mkLams [ax, axs] folder_body_outer_case ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) @@ -543,15 +543,12 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs -- Generate the expressions to build the grouped list -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold monads rather than single values - ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs - ; body <- dsMcStmts stmts_rest - ; n_tup_var' <- newSysLocalDs Many n_tup_ty' - ; tup_n_var' <- newSysLocalDs Many tup_n_ty' + ; n_tup_var' <- newSysLocalDs ManyTy n_tup_ty' ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys ; us <- newUniqueSupply ; let rhs' = mkApps usingExpr' usingArgs' - body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr' + body' = mkBigTupleCase us to_bndrs body tup_n_expr' ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } @@ -596,8 +593,8 @@ matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr -- \x. case x of (a,b,c) -> body matchTuple ids body = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy ids) - ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } + ; tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids) + ; return (Lam tup_id $ mkBigTupleCase us ids body (Var tup_id)) } -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a -- desugared `CoreExpr` @@ -610,7 +607,7 @@ dsMcBindStmt :: LPat GhcTc -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts - ; var <- selectSimpleMatchVarL Many pat + ; var <- selectSimpleMatchVarL ManyTy pat ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat res1_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op @@ -651,15 +648,15 @@ mkMcUnzipM ThenForm _ ys _ mkMcUnzipM _ fmap_op ys elt_tys = do { fmap_op' <- dsExpr fmap_op - ; xs <- mapM (newSysLocalDs Many) elt_tys + ; xs <- mapM (newSysLocalDs ManyTy) elt_tys ; let tup_ty = mkBigCoreTupTy elt_tys - ; tup_xs <- newSysLocalDs Many tup_ty + ; tup_xs <- newSysLocalDs ManyTy tup_ty ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b [ Type tup_ty, Type (getNth elt_tys i) , mk_sel i, Var ys] mk_sel n = Lam tup_xs $ - mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) + mkBigTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index fd3a9ee015..cc9d282356 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -38,27 +38,31 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.HsToCore.Pmc import GHC.HsToCore.Pmc.Types ( Nablas, initNablas ) -import GHC.Core -import GHC.Types.Literal -import GHC.Core.Utils -import GHC.Core.Make import GHC.HsToCore.Monad import GHC.HsToCore.Binds import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils -import GHC.Types.Id -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.PatSyn import GHC.HsToCore.Errors.Types import GHC.HsToCore.Match.Constructor import GHC.HsToCore.Match.Literal + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType, eqTypes ) import GHC.Core.Coercion ( eqCoercion ) import GHC.Core.TyCon ( isNewTyCon ) import GHC.Core.Multiplicity import GHC.Builtin.Types + +import GHC.Types.Id +import GHC.Types.Literal import GHC.Types.SrcLoc + import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Types.Name @@ -871,7 +875,7 @@ matchSinglePat (Var var) ctx pat ty match_result = matchSinglePatVar var Nothing ctx pat ty match_result matchSinglePat scrut hs_ctx pat ty match_result - = do { var <- selectSimpleMatchVarL Many pat + = do { var <- selectSimpleMatchVarL ManyTy pat -- matchSinglePat is only used in matchSimply, which -- is used in list comprehension, arrow notation, -- and to create field selectors. All of which only diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 61e0f750d0..1c21f2a5e6 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -36,29 +36,36 @@ import GHC.HsToCore.Utils import GHC.Hs -import GHC.Types.Id -import GHC.Types.SourceText +import GHC.Tc.Utils.Zonk ( shortCutLit ) +import GHC.Tc.Utils.TcType + import GHC.Core import GHC.Core.Make import GHC.Core.TyCon import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.DataCon -import GHC.Tc.Utils.Zonk ( shortCutLit ) -import GHC.Tc.Utils.TcType -import GHC.Types.Name import GHC.Core.Type +import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType ) + +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Types.SrcLoc + import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim -import GHC.Types.Literal -import GHC.Types.SrcLoc -import GHC.Utils.Outputable as Outputable + +import GHC.Types.Id +import GHC.Types.SourceText + import GHC.Driver.Session + +import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain + import GHC.Data.FastString -import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType ) import Control.Monad import Data.Int @@ -265,7 +272,7 @@ warnAboutIdentities :: DynFlags -> Id -> Type -> DsM () warnAboutIdentities dflags conv_fn type_of_conv | wopt Opt_WarnIdentities dflags , idName conv_fn `elem` conversionNames - , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv + , Just (_, _, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv , arg_ty `eqType` res_ty -- So we are converting ty -> ty = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv) warnAboutIdentities _ _ _ = return () diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 8a0b600a66..8723248f0a 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -378,7 +378,7 @@ duplicateLocalDs old_local newPredVarDs :: PredType -> DsM Var newPredVarDs - = mkSysLocalOrCoVarM (fsLit "ds") Many -- like newSysLocalDs, but we allow covars + = mkSysLocalOrCoVarM (fsLit "ds") ManyTy -- like newSysLocalDs, but we allow covars newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id newSysLocalDs = mkSysLocalM (fsLit "ds") diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index 8dac5e38d6..81d6de64a9 100644 --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -42,6 +42,7 @@ import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar) import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Type import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt @@ -139,7 +140,8 @@ desugarPat x pat = case pat of ListPat {} | ViewPat arg_ty _lexpr pat <- expansion , not (xopt LangExt.RebindableSyntax dflags) - , Just _ <- splitListTyConApp_maybe arg_ty + , Just tc <- tyConAppTyCon_maybe arg_ty + , tc == listTyCon -> desugarLPat x pat _ -> desugarPat x expansion @@ -247,7 +249,7 @@ desugarPat x pat = case pat of -- | 'desugarPat', but also select and return a new match var. desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd]) desugarPatV pat = do - x <- selectMatchVar Many pat + x <- selectMatchVar ManyTy pat grds <- desugarPat x pat pure (x, grds) diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index 17a24ced55..c3f57e83af 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -45,6 +45,7 @@ import GHC.Utils.Monad (allM) import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.Bag + import GHC.Types.Basic (Levity(..)) import GHC.Types.CompleteMatch import GHC.Types.Unique.Set @@ -55,14 +56,17 @@ import GHC.Types.Name import GHC.Types.Var (EvVar) import GHC.Types.Var.Env import GHC.Types.Var.Set +import GHC.Types.Unique.Supply + import GHC.Core -import GHC.Core.FVs (exprFreeVars) +import GHC.Core.FVs (exprFreeVars) +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Map.Expr import GHC.Core.Predicate (typeDeterminesValue) import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils (exprType) import GHC.Core.Make (mkListExpr, mkCharExpr, mkRuntimeErrorApp, rUNTIME_ERROR_ID) -import GHC.Types.Unique.Supply + import GHC.Data.FastString import GHC.Types.SrcLoc import GHC.Data.Maybe @@ -73,7 +77,6 @@ import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Builtin.Names import GHC.Builtin.Types -import GHC.Builtin.Types.Prim (tYPETyCon) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst (elemSubst) import GHC.Core.Type @@ -639,7 +642,7 @@ nameTyCt pred_ty = do unique <- getUniqueM let occname = mkVarOccFS (fsLit ("pm_"++show unique)) idname = mkInternalName unique occname noSrcSpan - return (mkLocalIdOrCoVar idname Many pred_ty) + return (mkLocalIdOrCoVar idname ManyTy pred_ty) ----------------------------- -- ** Adding term constraints diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs index e9c8c66033..49b386113e 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs @@ -57,6 +57,7 @@ import GHC.Core.Type import GHC.Core.TyCon import GHC.Types.Literal import GHC.Core +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Map.Expr import GHC.Core.Utils (exprType) import GHC.Builtin.Names diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs index b7279e24b2..9e0a40a5f3 100644 --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -52,7 +52,7 @@ mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique -> let occname = mkVarOccFS $ fsLit "pm" name = mkInternalName unique occname noSrcSpan - in return (mkLocalIdOrCoVar name Many ty) + in return (mkLocalIdOrCoVar name ManyTy ty) {-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough -- | All warning flags that need to run the pattern match checker. diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 18126d3a4f..00f770b6de 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -51,8 +51,8 @@ import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Core.DataCon import GHC.Core.TyCon -import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core +import GHC.Core.Type( pattern ManyTy, mkFunTy ) import GHC.Core.Make import GHC.Core.Utils @@ -129,8 +129,9 @@ mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do -- the expected type tyvars = dataConUserTyVarBinders (classDataCon cls) expected_ty = mkInvisForAllTys tyvars $ - mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars))) - (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) + mkFunTy invisArgConstraintLike ManyTy + (mkClassPred cls (mkTyVarTys (binderVars tyvars))) + (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty) @@ -1357,10 +1358,10 @@ repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) = repTy ty@(HsQualTy {}) = repForallT ty repTy (HsTyVar _ _ (L _ n)) - | isLiftedTypeKindTyConName n = repTStar + | n `hasKey` liftedTypeKindTyConKey = repTStar | n `hasKey` constraintKindTyConKey = repTConstraint | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon - | n `hasKey` funTyConKey = repMulArrowTyCon + | n `hasKey` fUNTyConKey = repMulArrowTyCon | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n @@ -2134,7 +2135,8 @@ mkGenSyms :: [Name] -> MetaM [GenSymBind] -- -- Nevertheless, it's monadic because we have to generate nameTy mkGenSyms ns = do { var_ty <- lookupType nameTyConName - ; return [(nm, mkLocalId (localiseName nm) Many var_ty) | nm <- ns] } + ; return [ (nm, mkLocalId (localiseName nm) ManyTy var_ty) + | nm <- ns] } addBinds :: [GenSymBind] -> MetaM a -> MetaM a @@ -2960,7 +2962,9 @@ repGetField (MkC exp) fs = do repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp)) repProjection fs = do - MkC xs <- coreListNonEmpty stringTy <$> mapM coreStringLit fs + ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName + MkC xs <- coreListNonEmpty ne_tycon stringTy <$> + mapM coreStringLit fs rep2 projectionEName [xs] ------------ Lists ------------------- @@ -2992,8 +2996,13 @@ coreList' :: Type -- The element type -> [Core a] -> Core [a] coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) -coreListNonEmpty :: Type -> NonEmpty (Core a) -> Core (NonEmpty a) -coreListNonEmpty ty (MkC x :| xs) = MkC $ mkNonEmptyListExpr ty x (map unC xs) +coreListNonEmpty :: TyCon -- TyCon for NonEmpty + -> Type -- Element type + -> NonEmpty (Core a) + -> Core (NonEmpty a) +coreListNonEmpty ne_tc ty (MkC x :| xs) + = MkC $ mkCoreConApps (tyConSingleDataCon ne_tc) + [Type ty, x, mkListExpr ty (map unC xs)] nonEmptyCoreList :: [Core a] -> Core [a] -- The list must be non-empty so we can get the element type diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 7564a3cd1c..f919a422c5 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -53,7 +53,6 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr ) import GHC.Hs import GHC.Hs.Syn.Type -import GHC.Tc.Utils.TcType( tcSplitTyConApp ) import GHC.Core import GHC.HsToCore.Monad @@ -143,7 +142,7 @@ selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) -- multiplicity stored within the variable -- itself. It's easier to pull it from the -- variable, so we ignore the multiplicity. -selectMatchVar _w (AsPat _ var _ _) = assert (isManyDataConTy _w ) (return (unLoc var)) +selectMatchVar _w (AsPat _ var _ _) = assert (isManyTy _w ) (return (unLoc var)) selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat) {- Note [Localise pattern binders] @@ -540,7 +539,7 @@ mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg case_bndr = case arg1 of Var v1 | isInternalName (idName v1) -> v1 -- Note [Desugaring seq], points (2) and (3) - _ -> mkWildValBinder Many ty1 + _ -> mkWildValBinder ManyTy ty1 mkCoreAppDs _ (Var f `App` Type _r) arg | f `hasKey` noinlineIdKey -- See Note [noinlineId magic] in GHC.Types.Id.Make @@ -630,7 +629,7 @@ There are two cases. Note that we return 't' as the variable to force if the pattern is strict (i.e. with -XStrict or an outermost-bang-pattern) - Note that (A) /includes/ the situation where + Note that (C) /includes/ the situation where * The pattern binds exactly one variable let !(Just (Just x) = e in body @@ -640,7 +639,8 @@ There are two cases. in t `seq` body The 'Solo' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types Note that forcing 't' makes the pattern match happen, - but does not force 'v'. + but does not force 'v'. That's why we call `mkBigCoreVarTupSolo` + in `mkSeletcorBinds` * The pattern binds no variables let !(True,False) = e in body @@ -738,7 +738,7 @@ mkSelectorBinds ticks pat val_expr | is_flat_prod_lpat pat' -- Special case (B) = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDs Many pat_ty + ; val_var <- newSysLocalDs ManyTy pat_ty ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } @@ -756,13 +756,13 @@ mkSelectorBinds ticks pat val_expr ; return ( val_var, (val_var, val_expr) : binds) } | otherwise -- General case (C) - = do { tuple_var <- newSysLocalDs Many tuple_ty + = do { tuple_var <- newSysLocalDs ManyTy tuple_ty ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr ; let mk_tup_bind tick binder = (binder, mkOptTickBox tick $ - mkTupleSelector1 local_binders binder + mkBigTupleSelectorSolo local_binders binder tuple_var (Var tuple_var)) tup_binds = zipWith mk_tup_bind ticks' binders ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } @@ -775,7 +775,7 @@ mkSelectorBinds ticks pat val_expr ticks' = ticks ++ repeat [] local_binders = map localiseId binders -- See Note [Localise pattern binders] - local_tuple = mkBigCoreVarTup1 binders + local_tuple = mkBigCoreVarTupSolo binders tuple_ty = exprType local_tuple strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) @@ -913,8 +913,8 @@ mkFailurePair :: CoreExpr -- Result type of the whole case expression CoreExpr) -- Fail variable applied to realWorld# -- See Note [Failure thunks and CPR] mkFailurePair expr - = do { fail_fun_var <- newFailLocalDs Many (unboxedUnitTy `mkVisFunTyMany` ty) - ; fail_fun_arg <- newSysLocalDs Many unboxedUnitTy + = do { fail_fun_var <- newFailLocalDs ManyTy (unboxedUnitTy `mkVisFunTyMany` ty) + ; fail_fun_arg <- newSysLocalDs ManyTy unboxedUnitTy ; let real_arg = setOneShotLambda fail_fun_arg ; return (NonRec fail_fun_var (Lam real_arg expr), App (Var fail_fun_var) unboxedUnitExpr) } @@ -997,7 +997,7 @@ mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr mkBinaryTickBox ixT ixF e = do uq <- newUnique this_mod <- getModule - let bndr1 = mkSysLocal (fsLit "t1") uq One boolTy + let bndr1 = mkSysLocal (fsLit "t1") uq OneTy boolTy -- It's always sufficient to pattern-match on a boolean with -- multiplicity 'One'. let diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index 5d5bacc123..db0218d73d 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -381,7 +381,7 @@ getSymtabName _name_cache _dict symtab bh = do in return $! case lookupKnownKeyName u of Nothing -> pprPanic "getSymtabName:unknown known-key unique" - (ppr i $$ ppr u) + (ppr i $$ ppr u $$ char tag $$ ppr ix) Just n -> n _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs index 714b23b7c2..b8a398465c 100644 --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -143,7 +143,7 @@ data HieType a = HTyVarTy Name | HAppTy a (HieArgs a) | HTyConApp IfaceTyCon (HieArgs a) - | HForAllTy ((Name, a),ArgFlag) a + | HForAllTy ((Name, a),ForAllTyFlag) a | HFunTy a a a | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') | HLitTy IfaceTyLit @@ -206,7 +206,7 @@ instance Binary (HieType TypeIndex) where -- | A list of type arguments along with their respective visibilities (ie. is --- this an argument that would return 'True' for 'isVisibleArgFlag'?). +-- this an argument that would return 'True' for 'isVisibleForAllTyFlag'?). newtype HieArgs a = HieArgs [(Bool,a)] deriving (Functor, Foldable, Traversable, Eq) diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index 954ab3af57..105e13acd9 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -13,7 +13,6 @@ import GHC.Driver.Session ( DynFlags ) import GHC.Driver.Ppr import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type -import GHC.Core.Multiplicity import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Utils.Outputable hiding ( (<>) ) @@ -22,6 +21,7 @@ import GHC.Types.SrcLoc import GHC.CoreToIface import GHC.Core.TyCon import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( nonDetCmpType ) import GHC.Core.Type import GHC.Types.Var import GHC.Types.Var.Env @@ -41,6 +41,7 @@ import Data.List (find) import Data.Traversable ( for ) import Data.Coerce import GHC.Utils.Monad.State.Strict hiding (get) +import GHC.Utils.Panic.Plain( assert ) import Control.Monad.Trans.Reader import qualified Data.Tree as Tree @@ -70,8 +71,8 @@ resolveVisibility kind ty_args | Just ty' <- coreView ty = go env ty' ts go env (ForAllTy (Bndr tv vis) res) (t:ts) - | isVisibleArgFlag vis = (True , t) : ts' - | otherwise = (False, t) : ts' + | isVisibleForAllTyFlag vis = (True , t) : ts' + | otherwise = (False, t) : ts' where ts' = go (extendTvSubst env tv t) res ts @@ -160,8 +161,8 @@ hieTypeToIface = foldType go go (HLitTy l) = IfaceLitTy l go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k) in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t - go (HFunTy w a b) = IfaceFunTy VisArg w a b - go (HQualTy pred b) = IfaceFunTy InvisArg many_ty pred b + go (HFunTy w a b) = IfaceFunTy visArgTypeLike w a b + go (HQualTy pred b) = IfaceFunTy invisArgTypeLike many_ty pred b go (HCastTy a) = a go HCoercionTy = IfaceTyVar "<coercion type>" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) @@ -240,9 +241,9 @@ getTypeIndex t ai <- getTypeIndex a bi <- getTypeIndex b wi <- getTypeIndex w - return $ case af of - InvisArg -> case w of Many -> HQualTy ai bi; _ -> error "Unexpected non-unrestricted predicate" - VisArg -> HFunTy wi ai bi + return $ if isInvisibleFunArg af + then assert (isManyTy w) $ HQualTy ai bi + else HFunTy wi ai bi go (LitTy a) = return $ HLitTy $ toIfaceTyLit a go (CastTy t _) = do i <- getTypeIndex t diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 6dd7f75509..c1c1666515 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -47,7 +47,7 @@ import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Ppr -import GHC.Core.Unify( RoughMatchTc(..) ) +import GHC.Core.RoughMap( RoughMatchTc(..) ) import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env @@ -559,7 +559,7 @@ tyConToIfaceDecl env tycon -- an error. (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) tc_tyvars = binderVars tc_binders - if_binders = toIfaceTyCoVarBinders tc_binders + if_binders = toIfaceForAllBndrs tc_binders -- No tidying of the binders; they are already tidy if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) if_syn_type ty = tidyToIfaceType tc_env1 ty @@ -601,7 +601,7 @@ tyConToIfaceDecl env tycon ifConInfix = dataConIsInfix data_con, ifConWrapper = isJust (dataConWrapId_maybe data_con), ifConExTCvs = map toIfaceBndr ex_tvs', - ifConUserTvBinders = map toIfaceForAllBndr user_bndrs', + ifConUserTvBinders = toIfaceForAllBndrs user_bndrs', ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, ifConCtxt = tidyToIfaceContext con_env2 theta, ifConArgTys = @@ -628,18 +628,18 @@ tyConToIfaceDecl env tycon -- A bit grimy, perhaps, but it's simple! (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs - user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs + user_bndrs' = map (tidyUserForAllTyBinder con_env2) user_bndrs to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) -- By this point, we have tidied every universal and existential - -- tyvar. Because of the dcUserTyCoVarBinders invariant + -- tyvar. Because of the dcUserForAllTyBinders invariant -- (see Note [DataCon user type variable binders]), *every* -- user-written tyvar must be contained in the substitution that -- tidying produced. Therefore, tidying the user-written tyvars is a -- simple matter of looking up each variable in the substitution, -- which tidyTyCoVarOcc accomplishes. - tidyUserTyCoVarBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder - tidyUserTyCoVarBinder env (Bndr tv vis) = + tidyUserForAllTyBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder + tidyUserForAllTyBinder env (Bndr tv vis) = Bndr (tidyTyCoVarOcc env tv) vis classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) @@ -647,7 +647,7 @@ classToIfaceDecl env clas = ( env1 , IfaceClass { ifName = getName tycon, ifRoles = tyConRoles (classTyCon clas), - ifBinders = toIfaceTyCoVarBinders tc_binders, + ifBinders = toIfaceForAllBndrs tc_binders, ifBody = body, ifFDs = map toIfaceFD clas_fds }) where @@ -702,7 +702,7 @@ tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) = case lookupVarEnv subst tv of Just tv' -> (env, Bndr tv' vis) - Nothing -> tidyTyCoVarBinder env tvb + Nothing -> tidyForAllTyBinder env tvb tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) tidyTyConBinders = mapAccumL tidyTyConBinder diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 8cbbb0e247..9c3716fe97 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -632,7 +632,7 @@ rnIfaceExpr (IfaceLet (IfaceRec pairs) body) rnIfaceExpr (IfaceCast expr co) = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) -rnIfaceExpr (IfaceLitRubbish rep) = IfaceLitRubbish <$> rnIfaceType rep +rnIfaceExpr (IfaceLitRubbish tc rep) = IfaceLitRubbish tc <$> rnIfaceType rep rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr @@ -693,7 +693,7 @@ rnIfaceCo (IfaceTransCo c1 c2) = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 rnIfaceCo (IfaceInstCo c1 c2) = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 -rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c +rnIfaceCo (IfaceSelCo d c) = IfaceSelCo d <$> rnIfaceCo c rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c rnIfaceCo (IfaceAxiomRuleCo ax cos) diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index c209a70123..2e7a39bc97 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -64,8 +64,8 @@ import GHC.Types.Basic import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) -import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders ) -import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) +import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike ) +import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.InferTags.TagSig @@ -560,8 +560,8 @@ data IfaceExpr | IfaceLet (IfaceBinding IfaceLetBndr) IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal - | IfaceLitRubbish IfaceType -- See GHC.Types.Literal - -- Note [Rubbish literals] item (6) + | IfaceLitRubbish TypeOrConstraint IfaceType + -- See GHC.Types.Literal Note [Rubbish literals] item (6) | IfaceFCall ForeignCall IfaceType | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E @@ -865,7 +865,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, pp_where = ppWhen (gadt && not (null cons)) $ text "where" pp_cons = ppr_trim (map show_con cons) :: [SDoc] pp_kind = ppUnless (if ki_sig_printable - then isIfaceTauType kind + then isIfaceRhoType kind -- Even in the presence of a standalone kind signature, a non-tau -- result kind annotation cannot be discarded as it determines the arity. -- See Note [Arity inference in kcCheckDeclHeader_sig] in GHC.Tc.Gen.HsType @@ -1073,7 +1073,8 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, , ppWhen insert_empty_ctxt $ parens empty <+> darrow , ex_msg , pprIfaceContextArr prov_ctxt - , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ]) + , pprIfaceType $ foldr (IfaceFunTy visArgTypeLike many_ty) + pat_ty arg_tys ]) pat_body = braces $ sep $ punctuate comma $ map ppr pat_fldlbls univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs ex_msg = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs @@ -1212,16 +1213,18 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent -- because we don't have a Name for the tycon, only an OccName pp_tau | null fields = case pp_args ++ [pp_gadt_res_ty] of - (t:ts) -> fsep (t : zipWithEqual "pprIfaceConDecl" (\(w,_) d -> ppr_arr w <+> d) arg_tys ts) + (t:ts) -> fsep (t : zipWithEqual "pprIfaceConDecl" (\(w,_) d -> ppr_arr w <+> d) + arg_tys ts) [] -> panic "pp_con_taus" | otherwise = sep [pp_field_args, arrow <+> pp_gadt_res_ty] -- Constructors are linear by default, but we don't want to show -- linear arrows when -XLinearTypes is disabled - ppr_arr w = sdocOption sdocLinearTypes (\linearTypes -> if linearTypes - then ppr_fun_arrow w - else arrow) + ppr_arr w = sdocOption sdocLinearTypes $ \linearTypes -> + if linearTypes + then pprTypeArrow visArgTypeLike w + else arrow ppr_bang IfNoBang = whenPprDebug $ char '_' ppr_bang IfStrict = char '!' @@ -1311,7 +1314,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent -- 3. Pretty-print the data type constructor applied to its arguments. -- This process will omit any invisible arguments, such as coercion -- variables, if necessary. (See Note - -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.) + -- [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.) ppr_tc_app gadt_subst = pprPrefixIfDeclBndr how_much (occName tycon) <+> pprParendIfaceAppArgs @@ -1320,7 +1323,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs mk_tc_app_args [] = IA_Nil mk_tc_app_args (Bndr bndr vis:tc_bndrs) = - IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis) + IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisForAllTyFlag vis) (mk_tc_app_args tc_bndrs) instance Outputable IfaceRule where @@ -1397,16 +1400,20 @@ pprParendIfaceExpr = pprIfaceExpr parens -- an atomic value (e.g. function args) pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc -pprIfaceExpr _ (IfaceLcl v) = ppr v -pprIfaceExpr _ (IfaceExt v) = ppr v -pprIfaceExpr _ (IfaceLit l) = ppr l -pprIfaceExpr _ (IfaceLitRubbish r) = text "RUBBISH" <> parens (ppr r) -pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) -pprIfaceExpr _ (IfaceType ty) = char '@' <> pprParendIfaceType ty -pprIfaceExpr _ (IfaceCo co) = text "@~" <> pprParendIfaceCoercion co +pprIfaceExpr _ (IfaceLcl v) = ppr v +pprIfaceExpr _ (IfaceExt v) = ppr v +pprIfaceExpr _ (IfaceLit l) = ppr l +pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr _ (IfaceType ty) = char '@' <> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <> pprParendIfaceCoercion co +pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) + +pprIfaceExpr _ (IfaceLitRubbish tc r) + = text "RUBBISH" + <> (case tc of { TypeLike -> empty; ConstraintLike -> text "[c]" }) + <> parens (ppr r) pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) -pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) pprIfaceExpr add_par i@(IfaceLam _ _) = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, @@ -1709,7 +1716,7 @@ freeNamesIfCoercion (IfaceSymCo c) = freeNamesIfCoercion c freeNamesIfCoercion (IfaceTransCo c1 c2) = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceNthCo _ co) +freeNamesIfCoercion (IfaceSelCo _ co) = freeNamesIfCoercion co freeNamesIfCoercion (IfaceLRCo _ co) = freeNamesIfCoercion co @@ -2388,9 +2395,12 @@ instance Binary IfaceExpr where putByte bh 13 put_ bh a put_ bh b - put_ bh (IfaceLitRubbish r) = do + put_ bh (IfaceLitRubbish TypeLike r) = do putByte bh 14 put_ bh r + put_ bh (IfaceLitRubbish ConstraintLike r) = do + putByte bh 15 + put_ bh r get bh = do h <- getByte bh case h of @@ -2434,7 +2444,9 @@ instance Binary IfaceExpr where b <- get bh return (IfaceECase a b) 14 -> do r <- get bh - return (IfaceLitRubbish r) + return (IfaceLitRubbish TypeLike r) + 15 -> do r <- get bh + return (IfaceLitRubbish ConstraintLike r) _ -> panic ("get IfaceExpr " ++ show h) instance Binary IfaceTickish where @@ -2691,7 +2703,7 @@ instance NFData IfaceExpr where IfaceLet bind e -> rnf bind `seq` rnf e IfaceCast e co -> rnf e `seq` rnf co IfaceLit l -> l `seq` () -- FIXME - IfaceLitRubbish r -> rnf r `seq` () + IfaceLitRubbish tc r -> tc `seq` rnf r `seq` () IfaceFCall fc ty -> fc `seq` rnf ty IfaceTick tick e -> rnf tick `seq` rnf e diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 831380c03b..a7bdf04a4b 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -28,7 +28,7 @@ module GHC.Iface.Type ( IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, IfaceForAllSpecBndr, - IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ShowForAllFlag(..), + IfaceForAllBndr, ForAllTyFlag(..), FunTyFlag(..), ShowForAllFlag(..), mkIfaceForAllTvBndr, mkIfaceTyConKind, ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr, @@ -39,8 +39,8 @@ module GHC.Iface.Type ( -- Equality testing isIfaceLiftedTypeKind, - -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags - appArgsIfaceTypes, appArgsIfaceTypesArgFlags, + -- Conversion from IfaceAppArgs to IfaceTypes/ForAllTyFlags + appArgsIfaceTypes, appArgsIfaceTypesForAllTyFlags, -- Printing SuppressBndrSig(..), @@ -55,9 +55,7 @@ module GHC.Iface.Type ( pprIfaceCoercion, pprParendIfaceCoercion, splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, - mulArrow, - ppr_fun_arrow, - isIfaceTauType, + isIfaceRhoType, suppressIfaceInvisibles, stripIfaceInvisVars, @@ -65,18 +63,20 @@ module GHC.Iface.Type ( mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst, - many_ty + many_ty, pprTypeArrow ) where import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( coercibleTyCon, heqTyCon + , constraintKindTyConName , tupleTyConName - , manyDataConTyCon, oneDataConTyCon + , manyDataConTyCon , liftedRepTyCon, liftedDataConTyCon ) -import GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy ) - +import GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy, funTyFlagTyCon ) +import GHC.Core.TyCo.Rep( CoSel ) +import GHC.Core.TyCo.Compare( eqForAllVis ) import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom import GHC.Types.Var @@ -162,7 +162,7 @@ data IfaceType -- See Note [Suppressing invisible arguments] for -- an explanation of why the second field isn't -- IfaceType, analogous to AppTy. - | IfaceFunTy AnonArgFlag IfaceMult IfaceType IfaceType + | IfaceFunTy FunTyFlag IfaceMult IfaceType IfaceType | IfaceForAllTy IfaceForAllBndr IfaceType | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated -- Includes newtypes, synonyms, tuples @@ -192,11 +192,11 @@ data IfaceTyLit deriving (Eq) type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +type IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag type IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity -- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. -mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr +mkIfaceForAllTvBndr :: ForAllTyFlag -> IfaceTvBndr -> IfaceForAllBndr mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis -- | Build the 'tyConKind' from the binders and the result kind. @@ -220,7 +220,7 @@ data IfaceAppArgs = IA_Nil | IA_Arg IfaceType -- The type argument - ArgFlag -- The argument's visibility. We store this here so + ForAllTyFlag -- The argument's visibility. We store this here so -- that we can: -- -- 1. Avoid pretty-printing invisible (i.e., specified @@ -389,7 +389,7 @@ data IfaceCoercion | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType | IfaceSymCo IfaceCoercion | IfaceTransCo IfaceCoercion IfaceCoercion - | IfaceNthCo Int IfaceCoercion + | IfaceSelCo CoSel IfaceCoercion | IfaceLRCo LeftOrRight IfaceCoercion | IfaceInstCo IfaceCoercion IfaceCoercion | IfaceKindCo IfaceCoercion @@ -416,7 +416,7 @@ IfaceHoleCo to ensure that they don't end up in an interface file. %************************************************************************ %* * - Functions over IFaceTypes + Functions over IfaceTypes * * ************************************************************************ -} @@ -424,35 +424,55 @@ IfaceHoleCo to ensure that they don't end up in an interface file. ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key --- | Given a kind K, is K of the form (TYPE ('BoxedRep 'LiftedRep))? +-- | Returns true for Type or (TYPE LiftedRep) isIfaceLiftedTypeKind :: IfaceKind -> Bool -isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) - = isLiftedTypeKindTyConName (ifaceTyConName tc) -isIfaceLiftedTypeKind (IfaceTyConApp tc1 args1) - = isIfaceTyConAppLiftedTypeKind tc1 args1 +isIfaceLiftedTypeKind (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + , IA_Nil <- args + = True -- Type + + | tc `ifaceTyConHasKey` tYPETyConKey + , IA_Arg arg1 Required IA_Nil <- args + , isIfaceLiftedRep arg1 + = True -- TYPE Lifted + isIfaceLiftedTypeKind _ = False --- | Given a kind constructor K and arguments A, returns true if --- both of the following statements are true: --- --- * K is TYPE --- * A is a singleton IfaceAppArgs of the form ('BoxedRep 'Lifted) --- --- For the second condition, we must also check for the type --- synonym LiftedRep. -isIfaceTyConAppLiftedTypeKind :: IfaceTyCon -> IfaceAppArgs -> Bool -isIfaceTyConAppLiftedTypeKind tc1 args1 - | tc1 `ifaceTyConHasKey` tYPETyConKey - , IA_Arg soleArg1 Required IA_Nil <- args1 - , IfaceTyConApp rep args2 <- soleArg1 = - if | rep `ifaceTyConHasKey` boxedRepDataConKey - , IA_Arg soleArg2 Required IA_Nil <- args2 - , IfaceTyConApp lev IA_Nil <- soleArg2 - , lev `ifaceTyConHasKey` liftedDataConKey -> True - | rep `ifaceTyConHasKey` liftedRepTyConKey - , IA_Nil <- args2 -> True - | otherwise -> False - | otherwise = False +-- | Returns true for Constraint or (CONSTRAINT LiftedRep) +isIfaceConstraintKind :: IfaceKind -> Bool +isIfaceConstraintKind (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` constraintKindTyConKey + , IA_Nil <- args + = True -- Type + + | tc `ifaceTyConHasKey` cONSTRAINTTyConKey + , IA_Arg arg1 Required IA_Nil <- args + , isIfaceLiftedRep arg1 + = True -- TYPE Lifted + +isIfaceConstraintKind _ = False + +isIfaceLiftedRep :: IfaceKind -> Bool +-- Returns true for LiftedRep, or BoxedRep Lifted +isIfaceLiftedRep (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` liftedRepTyConKey + , IA_Nil <- args + = True -- LiftedRep + + | tc `ifaceTyConHasKey` boxedRepDataConKey + , IA_Arg arg1 Required IA_Nil <- args + , isIfaceLifted arg1 + = True -- TYPE Lifted + +isIfaceLiftedRep _ = False + +isIfaceLifted :: IfaceKind -> Bool +-- Returns true for Lifted +isIfaceLifted (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` liftedDataConKey + , IA_Nil <- args + = True +isIfaceLifted _ = False splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) -- Mainly for printing purposes @@ -478,17 +498,18 @@ splitIfaceSigmaTy ty (theta, tau) = split_rho rho split_foralls (IfaceForAllTy bndr ty) - | isInvisibleArgFlag (binderArgFlag bndr) + | isInvisibleForAllTyFlag (binderFlag bndr) = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } split_foralls rho = ([], rho) - split_rho (IfaceFunTy InvisArg _ ty1 ty2) + split_rho (IfaceFunTy af _ ty1 ty2) + | isInvisibleFunArg af = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) splitIfaceReqForallTy :: IfaceType -> ([IfaceForAllBndr], IfaceType) splitIfaceReqForallTy (IfaceForAllTy bndr ty) - | isVisibleArgFlag (binderArgFlag bndr) + | isVisibleForAllTyFlag (binderFlag bndr) = case splitIfaceReqForallTy ty of { (bndrs, rho) -> (bndr:bndrs, rho) } splitIfaceReqForallTy rho = ([], rho) @@ -590,7 +611,7 @@ substIfaceType env ty go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) go_co (IfaceSymCo co) = IfaceSymCo (go_co co) go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) - go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) + go_co (IfaceSelCo n co) = IfaceSelCo n (go_co co) go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) go_co (IfaceKindCo co) = IfaceKindCo (go_co co) @@ -633,12 +654,12 @@ stripInvisArgs (PrintExplicitKinds False) tys = suppress_invis tys = case c of IA_Nil -> IA_Nil IA_Arg t argf ts - | isVisibleArgFlag argf + | isVisibleForAllTyFlag argf -> IA_Arg t argf $ suppress_invis ts -- Keep recursing through the remainder of the arguments, as it's -- possible that there are remaining invisible ones. -- See the "In type declarations" section of Note [VarBndrs, - -- TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. + -- ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. | otherwise -> suppress_invis ts @@ -646,17 +667,17 @@ appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] appArgsIfaceTypes IA_Nil = [] appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts -appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)] -appArgsIfaceTypesArgFlags IA_Nil = [] -appArgsIfaceTypesArgFlags (IA_Arg t a ts) - = (t, a) : appArgsIfaceTypesArgFlags ts +appArgsIfaceTypesForAllTyFlags :: IfaceAppArgs -> [(IfaceType, ForAllTyFlag)] +appArgsIfaceTypesForAllTyFlags IA_Nil = [] +appArgsIfaceTypesForAllTyFlags (IA_Arg t a ts) + = (t, a) : appArgsIfaceTypesForAllTyFlags ts ifaceVisAppArgsLength :: IfaceAppArgs -> Int ifaceVisAppArgsLength = go 0 where go !n IA_Nil = n go n (IA_Arg _ argf rest) - | isVisibleArgFlag argf = go (n+1) rest + | isVisibleForAllTyFlag argf = go (n+1) rest | otherwise = go n rest {- @@ -746,7 +767,7 @@ kind application syntax to distinguish the two cases: Here, @{k} indicates that `k` is an inferred argument, and @k indicates that `k` is a specified argument. (See -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for a lengthier explanation on what "inferred" and "specified" mean.) ************************************************************************ @@ -778,10 +799,10 @@ pprIfacePrefixApp ctxt_prec pp_fun pp_tys | otherwise = maybeParen ctxt_prec appPrec $ hang pp_fun 2 (sep pp_tys) -isIfaceTauType :: IfaceType -> Bool -isIfaceTauType (IfaceForAllTy _ _) = False -isIfaceTauType (IfaceFunTy InvisArg _ _ _) = False -isIfaceTauType _ = True +isIfaceRhoType :: IfaceType -> Bool +isIfaceRhoType (IfaceForAllTy _ _) = False +isIfaceRhoType (IfaceFunTy af _ _ _) = isVisibleFunArg af +isIfaceRhoType _ = True -- ----------------------------- Printing binders ------------------------------------ @@ -823,10 +844,17 @@ Here we'd like to omit the kind annotation: Note [Printing type abbreviations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, we pretty-print `TYPE 'LiftedRep` as `Type` (or `*`) and -`FUN 'Many` as `(->)`. +Normally, we pretty-print + `TYPE 'LiftedRep` as `Type` (or `*`) + `CONSTRAINT 'LiftedRep` as `Constraint` (or `*`) + `FUN 'Many` as `(->)`. This way, error messages don't refer to representation polymorphism -or linearity if it is not necessary. +or linearity if it is not necessary. Normally we'd would represent +these types using their synonyms (see GHC.Core.Type +Note [Using synonyms to compress types]), but in the :kind! GHCi +command we specifically expand synonyms (see GHC.Tc.Module.tcRnExpr). +So here in the pretty-printing we effectively collapse back Type +and Constraint to their synonym forms. A bit confusing! However, when printing the definition of Type or (->) with :info, this would give confusing output: `type (->) = (->)` (#18594). @@ -862,9 +890,11 @@ pprIfaceTyConBinders suppress_sig = sep . map go go (Bndr (IfaceTvBndr bndr) vis) = -- See Note [Pretty-printing invisible arguments] case vis of - AnonTCB VisArg -> ppr_bndr (UseBndrParens True) - AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) - -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.) + AnonTCB af + | isVisibleFunArg af -> ppr_bndr (UseBndrParens True) + | otherwise -> char '@' <> braces (ppr_bndr (UseBndrParens False)) + -- The above case is rare. (See Note [AnonTCB with constraint arg] + -- in GHC.Core.TyCon.) -- Should we print these differently? NamedTCB Required -> ppr_bndr (UseBndrParens True) NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) @@ -914,43 +944,51 @@ pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc pprPrecIfaceType prec ty = hideNonStandardTypes (ppr_ty prec) ty --- mulArrow takes a pretty printer for the type it is being called on to --- allow type applications to be printed with the correct precedence inside --- the multiplicity e.g. a %(m n) -> b. See #20315. -mulArrow :: (PprPrec -> a -> SDoc) -> a -> SDoc -mulArrow ppr_mult mult = text "%" <> ppr_mult appPrec mult <+> arrow - -ppr_fun_arrow :: IfaceMult -> SDoc -ppr_fun_arrow w - | (IfaceTyConApp tc _) <- w - , tc `ifaceTyConHasKey` (getUnique manyDataConTyCon) = arrow - | (IfaceTyConApp tc _) <- w - , tc `ifaceTyConHasKey` (getUnique oneDataConTyCon) = lollipop - | otherwise = mulArrow pprPrecIfaceType w - -ppr_sigma :: PprPrec -> IfaceType -> SDoc -ppr_sigma ctxt_prec ty - = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) +pprTypeArrow :: FunTyFlag -> IfaceMult -> SDoc +pprTypeArrow af mult + = pprArrow (mb_conc, pprPrecIfaceType) af mult + where + mb_conc (IfaceTyConApp tc _) = Just tc + mb_conc _ = Nothing + +pprArrow :: (a -> Maybe IfaceTyCon, PprPrec -> a -> SDoc) + -> FunTyFlag -> a -> SDoc +-- Prints a thin arrow (->) with its multiplicity +-- Used for both FunTy and FunCo, hence higher order arguments +pprArrow (mb_conc, ppr_mult) af mult + | isFUNArg af + = case mb_conc mult of + Just tc | tc `ifaceTyConHasKey` manyDataConKey -> arrow + | tc `ifaceTyConHasKey` oneDataConKey -> lollipop + _ -> text "%" <> ppr_mult appPrec mult <+> arrow + | otherwise + = ppr (funTyFlagTyCon af) ppr_ty :: PprPrec -> IfaceType -> SDoc -ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty -ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _ _) = ppr_sigma ctxt_prec ty - +ppr_ty ctxt_prec ty + | not (isIfaceRhoType ty) = ppr_sigma ShowForAllMust ctxt_prec ty +ppr_ty _ (IfaceForAllTy {}) = panic "ppr_ty" -- Covered by not.isIfaceRhoType ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free tyvars in IfaceType] ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys -- always fully saturated ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n + -- Function types -ppr_ty ctxt_prec (IfaceFunTy _ w ty1 ty2) -- Should be VisArg - = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. +ppr_ty ctxt_prec ty@(IfaceFunTy af w ty1 ty2) -- Should be a visible argument + = assertPpr (isVisibleFunArg af) (ppr ty) $ -- Ensured by isIfaceRhoType above + -- We want to print a chain of arrows in a column + -- type1 + -- -> type2 + -- -> type3 maybeParen ctxt_prec funPrec $ sep [ppr_ty funPrec ty1, sep (ppr_fun_tail w ty2)] where - ppr_fun_tail wthis (IfaceFunTy VisArg wnext ty1 ty2) - = (ppr_fun_arrow wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 + ppr_fun_tail wthis (IfaceFunTy af wnext ty1 ty2) + | isVisibleFunArg af + = (pprTypeArrow af wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 ppr_fun_tail wthis other_ty - = [ppr_fun_arrow wthis <+> pprIfaceType other_ty] + = [pprTypeArrow af wthis <+> pprIfaceType other_ty] ppr_ty ctxt_prec (IfaceAppTy t ts) = if_print_coercions @@ -959,7 +997,7 @@ ppr_ty ctxt_prec (IfaceAppTy t ts) where ppr_app_ty = sdocOption sdocPrintExplicitKinds $ \print_kinds -> - let tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs + let tys_wo_kinds = appArgsIfaceTypesForAllTyFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) ts in pprIfacePrefixApp ctxt_prec (ppr_ty funPrec t) @@ -1066,7 +1104,7 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv ty -> IfaceType -> IfaceType go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) - | isInvisibleArgFlag argf -- Don't default *visible* quantification + | isInvisibleForAllTyFlag argf -- Don't default *visible* quantification -- or we get the mess in #13963 , Just substituted_ty <- check_substitution var_kind = let subs' = extendFsEnv subs var substituted_ty @@ -1161,9 +1199,8 @@ lifted_ty = -- | The type 'Many :: Multiplicity'. many_ty :: IfaceType -many_ty = - IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) - IA_Nil +many_ty = IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil where dc_name = getName manyDataConTyCon hideNonStandardTypes :: (IfaceType -> SDoc) -> IfaceType -> SDoc @@ -1192,7 +1229,7 @@ ppr_app_args ctx_prec = go go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts -- See Note [Pretty-printing invisible arguments] -ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc +ppr_app_arg :: PprPrec -> (IfaceType, ForAllTyFlag) -> SDoc ppr_app_arg ctx_prec (t, argf) = sdocOption sdocPrintExplicitKinds $ \print_kinds -> case argf of @@ -1244,12 +1281,12 @@ pprIfaceForAll bndrs@(Bndr _ vis : _) -- Returns both the list of not-yet-rendered binders and the doc. -- No anonymous binders here! ppr_itv_bndrs :: [IfaceForAllBndr] - -> ArgFlag -- ^ visibility of the first binder in the list + -> ForAllTyFlag -- ^ visibility of the first binder in the list -> ([IfaceForAllBndr], [SDoc]) ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 - | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in - (bndrs', pprIfaceForAllBndr bndr : doc) - | otherwise = (all_bndrs, []) + | vis `eqForAllVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in + (bndrs', pprIfaceForAllBndr bndr : doc) + | otherwise = (all_bndrs, []) ppr_itv_bndrs [] _ = ([], []) pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc @@ -1284,11 +1321,13 @@ data ShowForAllFlag = ShowForAllMust | ShowForAllWhen pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc pprIfaceSigmaType show_forall ty - = hideNonStandardTypes ppr_fn ty - where - ppr_fn iface_ty = - let (invis_tvs, theta, tau) = splitIfaceSigmaTy iface_ty - (req_tvs, tau') = splitIfaceReqForallTy tau + = hideNonStandardTypes (ppr_sigma show_forall topPrec) ty + +ppr_sigma :: ShowForAllFlag -> PprPrec -> IfaceType -> SDoc +ppr_sigma show_forall ctxt_prec iface_ty + = maybeParen ctxt_prec funPrec $ + let (invis_tvs, theta, tau) = splitIfaceSigmaTy iface_ty + (req_tvs, tau') = splitIfaceReqForallTy tau -- splitIfaceSigmaTy is recursive, so it will gather the binders after -- the theta, i.e. forall a. theta => forall b. tau -- will give you ([a,b], theta, tau). @@ -1302,8 +1341,8 @@ pprIfaceSigmaType show_forall ty -- non-recursive (see #18458). -- Then it could handle both invisible and required binders, and -- splitIfaceReqForallTy wouldn't be necessary here. - in ppr_iface_forall_part show_forall invis_tvs theta $ - sep [pprIfaceForAll req_tvs, ppr tau'] + in ppr_iface_forall_part show_forall invis_tvs theta $ + sep [pprIfaceForAll req_tvs, ppr tau'] pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc pprUserIfaceForAll tvs @@ -1318,7 +1357,7 @@ pprUserIfaceForAll tvs = not (ifTypeIsVarFree kind) tv_has_kind_var _ = False - tv_is_required = isVisibleArgFlag . binderArgFlag + tv_is_required = isVisibleForAllTyFlag . binderFlag {- Note [When to print foralls] @@ -1348,7 +1387,7 @@ criteria are met: because omitting it and printing "T :: k -> Type" would be utterly misleading. - See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] + See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. N.B. Until now (Aug 2018) we didn't check anything for coercion variables. @@ -1446,7 +1485,7 @@ pprIfaceTyList ctxt_prec ty1 ty2 gather (IfaceTyConApp tc tys) | tc `ifaceTyConHasKey` consDataConKey , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys - , isInvisibleArgFlag argf + , isInvisibleForAllTyFlag argf , (args, tl) <- gather ty2 = (ty1:args, tl) | tc `ifaceTyConHasKey` nilDataConKey @@ -1483,20 +1522,25 @@ pprTyTcApp ctxt_prec tc tys = | tc `ifaceTyConHasKey` consDataConKey , False <- print_kinds , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys - , isInvisibleArgFlag argf + , isInvisibleForAllTyFlag argf -> pprIfaceTyList ctxt_prec ty1 ty2 - | isIfaceTyConAppLiftedTypeKind tc tys + | isIfaceLiftedTypeKind (IfaceTyConApp tc tys) , print_type_abbreviations -- See Note [Printing type abbreviations] -> ppr_kind_type ctxt_prec - | tc `ifaceTyConHasKey` funTyConKey + | isIfaceConstraintKind (IfaceTyConApp tc tys) + , print_type_abbreviations -- See Note [Printing type abbreviations] + -> pprPrefixOcc constraintKindTyConName + + | tc `ifaceTyConHasKey` fUNTyConKey , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys , rep `ifaceTyConHasKey` manyDataConKey , print_type_abbreviations -- See Note [Printing type abbreviations] -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_app_arg appPrec) $ - appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) args) - -- Use appArgsIfaceTypesArgFlags to print invisible arguments + appArgsIfaceTypesForAllTyFlags $ + stripInvisArgs (PrintExplicitKinds print_kinds) args) + -- Use appArgsIfaceTypesForAllTyFlags to print invisible arguments -- correctly (#19310) | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey @@ -1509,7 +1553,7 @@ pprTyTcApp ctxt_prec tc tys = | otherwise -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $ - appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys + appArgsIfaceTypesForAllTyFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys where info = ifaceTyConInfo tc @@ -1619,8 +1663,8 @@ pprIfaceCoTcApp ctxt_prec tc tys = -- 1. Types (from `pprTyTcApp'`) -- -- 2. Coercions (from 'pprIfaceCoTcApp') -ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) - -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc +ppr_iface_tc_app :: (PprPrec -> (a, ForAllTyFlag) -> SDoc) + -> PprPrec -> IfaceTyCon -> [(a, ForAllTyFlag)] -> SDoc ppr_iface_tc_app pp ctxt_prec tc tys = sdocOption sdocListTuplePuns $ \listTuplePuns -> @@ -1721,15 +1765,20 @@ ppr_co _ (IfaceGReflCo r ty IfaceMRefl) ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) = ppr_special_co ctxt_prec (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] -ppr_co ctxt_prec (IfaceFunCo r cow co1 co2) + +ppr_co ctxt_prec (IfaceFunCo r co_mult co1 co2) = maybeParen ctxt_prec funPrec $ - sep (ppr_co funPrec co1 : ppr_fun_tail cow co2) + sep (ppr_co funPrec co1 : ppr_fun_tail co_mult co2) where - ppr_fun_tail cow' (IfaceFunCo r cow co1 co2) - = (coercionArrow cow' <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail cow co2 - ppr_fun_tail cow' other_co - = [coercionArrow cow' <> ppr_role r <+> pprIfaceCoercion other_co] - coercionArrow w = mulArrow ppr_co w + ppr_fun_tail co_mult1 (IfaceFunCo r co_mult2 co1 co2) + = (ppr_arrow co_mult1 <> ppr_role r <+> ppr_co funPrec co1) + : ppr_fun_tail co_mult2 co2 + ppr_fun_tail co_mult1 other_co + = [ppr_arrow co_mult1 <> ppr_role r <+> pprIfaceCoercion other_co] + + ppr_arrow = pprArrow (mb_conc, ppr_co) visArgTypeLike + mb_conc (IfaceTyConAppCo _ tc _) = Just tc + mb_conc _ = Nothing ppr_co _ (IfaceTyConAppCo r tc cos) = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r @@ -1776,8 +1825,8 @@ ppr_co ctxt_prec (IfaceTransCo co1 co2) ppr_trans c = [semi <+> ppr_co opPrec c] in maybeParen ctxt_prec opPrec $ vcat (ppr_co topPrec co1 : ppr_trans co2) -ppr_co ctxt_prec (IfaceNthCo d co) - = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] +ppr_co ctxt_prec (IfaceSelCo d co) + = ppr_special_co ctxt_prec (text "SelCo:" <> ppr d) [co] ppr_co ctxt_prec (IfaceLRCo lr co) = ppr_special_co ctxt_prec (ppr lr) [co] ppr_co ctxt_prec (IfaceSubCo co) @@ -2067,7 +2116,7 @@ instance Binary IfaceCoercion where putByte bh 11 put_ bh a put_ bh b - put_ bh (IfaceNthCo a b) = do + put_ bh (IfaceSelCo a b) = do putByte bh 12 put_ bh a put_ bh b @@ -2104,10 +2153,10 @@ instance Binary IfaceCoercion where b <- get bh c <- get bh return $ IfaceGReflCo a b c - 3 -> do a <- get bh - w <- get bh - b <- get bh - c <- get bh + 3 -> do a <- get bh + w <- get bh + b <- get bh + c <- get bh return $ IfaceFunCo a w b c 4 -> do a <- get bh b <- get bh @@ -2138,7 +2187,7 @@ instance Binary IfaceCoercion where return $ IfaceTransCo a b 12-> do a <- get bh b <- get bh - return $ IfaceNthCo a b + return $ IfaceSelCo a b 13-> do a <- get bh b <- get bh return $ IfaceLRCo a b @@ -2224,7 +2273,7 @@ instance NFData IfaceCoercion where IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 IfaceSymCo f1 -> rnf f1 IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceNthCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceSelCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceLRCo f1 f2 -> f1 `seq` rnf f2 IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceKindCo f1 -> rnf f1 diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 0df2dec9bc..a2d63bb779 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -57,7 +57,7 @@ import GHC.Core.TyCo.Subst ( substTyCoVars ) import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core -import GHC.Core.Unify( RoughMatchTc(..) ) +import GHC.Core.RoughMap( RoughMatchTc(..) ) import GHC.Core.Utils import GHC.Core.Unfold( calcUnfoldingGuidance ) import GHC.Core.Unfold.Make @@ -1454,11 +1454,10 @@ tcIfaceCo = go go (IfaceReflCo t) = Refl <$> tcIfaceType t go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco - go (IfaceFunCo r w c1 c2) = mkFunCo r <$> go w <*> go c1 <*> go c2 - go (IfaceTyConAppCo r tc cs) - = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs + go (IfaceFunCo r w c1 c2) = mkFunCoNoFTF r <$> go w <*> go c1 <*> go c2 + go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 - go (IfaceForAllCo tv k c) = do { k' <- go k + go (IfaceForAllCo tv k c) = do { k' <- go k ; bindIfaceBndr tv $ \ tv' -> ForAllCo tv' k' <$> go c } go (IfaceCoVarCo n) = CoVarCo <$> go_var n @@ -1470,8 +1469,8 @@ tcIfaceCo = go <*> go c2 go (IfaceInstCo c1 t2) = InstCo <$> go c1 <*> go t2 - go (IfaceNthCo d c) = do { c' <- go c - ; return $ mkNthCo (nthCoRole d c') d c' } + go (IfaceSelCo d c) = do { c' <- go c + ; return $ mkSelCo d c' } go (IfaceLRCo lr c) = LRCo lr <$> go c go (IfaceKindCo c) = KindCo <$> go c go (IfaceSubCo c) = SubCo <$> go c @@ -1513,9 +1512,9 @@ tcIfaceExpr (IfaceLcl name) tcIfaceExpr (IfaceExt gbl) = Var <$> tcIfaceExtId gbl -tcIfaceExpr (IfaceLitRubbish rep) +tcIfaceExpr (IfaceLitRubbish tc rep) = do rep' <- tcIfaceType rep - return (Lit (LitRubbish rep')) + return (Lit (LitRubbish tc rep')) tcIfaceExpr (IfaceLit lit) = do lit' <- tcIfaceLit lit @@ -1560,7 +1559,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let scrut_ty = exprType scrut' - case_mult = Many + case_mult = ManyTy case_bndr' = mkLocalIdOrCoVar case_bndr_name case_mult scrut_ty -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. @@ -1580,7 +1579,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) ; ty' <- tcIfaceType ty ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} NotTopLevel name ty' info - ; let id = mkLocalIdWithInfo name Many ty' id_info + ; let id = mkLocalIdWithInfo name ManyTy ty' id_info `asJoinId_maybe` tcJoinInfo ji ; rhs' <- tcIfaceExpr rhs ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) @@ -1596,7 +1595,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body) tc_rec_bndr (IfLetBndr fs ty _ ji) = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; return (mkLocalId name Many ty' `asJoinId_maybe` tcJoinInfo ji) } + ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` tcJoinInfo ji) } tc_pair (IfLetBndr _ _ info _, rhs) id = do { rhs' <- tcIfaceExpr rhs ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index cc2dcf2749..beff8acf64 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -77,7 +77,7 @@ import GHC.Types.SourceFile import GHC.Types.SourceText import GHC.Types.PkgQual -import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) ) +import GHC.Core.Type ( Specificity(..) ) import GHC.Core.Class ( FunDep ) import GHC.Core.DataCon ( DataCon, dataConName ) @@ -92,7 +92,8 @@ import GHC.Parser.Errors.Ppr () import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, - listTyCon_RDR, consDataCon_RDR) + listTyCon_RDR, consDataCon_RDR, + unrestrictedFunTyCon ) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 2dd8e06b3e..02ef74efef 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -137,10 +137,11 @@ import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr () import GHC.Utils.Lexeme ( okConOcc ) import GHC.Types.TyThing -import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) ) +import GHC.Core.Type ( Specificity(..) ) import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, - listTyConName, listTyConKey ) + listTyConName, listTyConKey, + unrestrictedFunTyCon ) import GHC.Types.ForeignCall import GHC.Types.SrcLoc import GHC.Types.Unique ( hasKey ) diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 48a8aa807f..1d84d794ae 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -33,7 +33,7 @@ import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) import GHC.Types.Error -import GHC.Types.Basic ( TopLevelFlag, isTopLevel ) +import GHC.Types.Basic ( TopLevelFlag, isTopLevel, maxPrec ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Utils.Outputable import GHC.Unit.Module @@ -673,23 +673,35 @@ rnSpliceType splice = ( makePending UntypedTypeSplice name rn_splice , HsSpliceTy (HsUntypedSpliceNested name) rn_splice) + run_type_splice :: HsUntypedSplice GhcRn -> RnM (HsType GhcRn, FreeVars) run_type_splice rn_splice = do { traceRn "rnSpliceType: untyped type splice" empty ; (hs_ty2, mod_finalizers) <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 ; checkNoErrs $ rnLHsType doc hs_ty2 } - -- checkNoErrs: see Note [Renamer errors] + -- checkNoErrs: see Note [Renamer errors] + -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsParTy noAnn - $ flip HsSpliceTy rn_splice - . HsUntypedSpliceTop (ThModFinalizers mod_finalizers) - <$> hs_ty3 + ; return ( HsSpliceTy (HsUntypedSpliceTop (ThModFinalizers mod_finalizers) + (mb_paren hs_ty3)) + rn_splice , fvs ) } -- Wrap the result of the splice in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) + -- Wrap a non-atomic result in HsParTy parens; + -- but not if it's atomic to avoid double parens for operators + -- This is to account for, say foo :: $(blah) -> Int + -- when we want $(blah) to expand to (this -> that), with parens. + -- Sadly, it's awkward add precisely the correct parens, because + -- that depends on the context. + mb_paren :: LHsType GhcRn -> LHsType GhcRn + mb_paren lhs_ty@(L loc hs_ty) + | hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty) + | otherwise = lhs_ty + {- Note [Partial Type Splices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Partial Type Signatures are partially supported in TH type splices: only diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 75a6123891..0b62544433 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -72,6 +72,7 @@ import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.TyCon import GHC.Core.Type hiding( typeKind ) +import GHC.Core.TyCo.Ppr import qualified GHC.Core.Type as Type import GHC.Iface.Env ( newInteractiveBinder ) @@ -668,9 +669,12 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do Nothing -> return hsc_env Just new_ty -> do case improveRTTIType hsc_env old_ty new_ty of - Nothing -> return $ - warnPprTrace True (":print failed to calculate the " - ++ "improvement for a type") empty hsc_env + Nothing -> warnPprTrace True (":print failed to calculate the " + ++ "improvement for a type") + (vcat [ text "id" <+> ppr id + , text "old_ty" <+> debugPprType old_ty + , text "new_ty" <+> debugPprType new_ty ]) $ + return hsc_env Just subst -> do let logger = hsc_logger hsc_env putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" @@ -1071,8 +1075,8 @@ findMatchingInstances ty = do k -> Constraint where k is the type of the queried type. -} try_cls ies cls - | Just (_, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) - , tcIsConstraintKind res_kind + | Just (_, _, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) + , isConstraintKind res_kind , Type.typeKind ty `eqType` arg_kind , (matches, _, _) <- lookupInstEnv True ies cls [ty] = matches diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 8357eb1bdb..ec13338d0c 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -36,7 +36,8 @@ import GHC.Core.Type import GHC.Types.RepType import GHC.Core.Multiplicity import qualified GHC.Core.Unify as U -import GHC.Types.Var +import GHC.Core.TyCon + import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType @@ -44,7 +45,7 @@ import GHC.Tc.Utils.Zonk ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( Runtime import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env -import GHC.Core.TyCon +import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Occurrence as OccName import GHC.Unit.Module @@ -675,7 +676,7 @@ applyRevSubst pairs = liftTcM (mapM_ do_pair pairs) where do_pair (tc_tv, rtti_tv) = do { tc_ty <- zonkTcTyVar tc_tv - ; case tcGetTyVar_maybe tc_ty of + ; case getTyVar_maybe tc_ty of Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv) _ -> return () } @@ -748,10 +749,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- we have unsound types. Replace constructor types in -- subterms with tyvars zterm' <- mapTermTypeM - (\ty -> case tcSplitTyConApp_maybe ty of - Just (tc, _:_) | tc /= funTyCon - -> newOpenVar - _ -> return ty) + (\ty -> case splitTyConApp_maybe ty of + -- SPJ: I have no idea why we are + -- matching on (:) here, nor + -- what the isFunTy is for + Just (_tc, _ : _) | not (isFunTy ty) + -> newOpenVar + _ -> return ty) term zonkTerm zterm' traceTR (text "Term reconstruction completed." $$ @@ -1346,12 +1350,13 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') ppr tv, equals, ppr ty_v] go ty_v r -- FunTy inductive case - | Just (w1,l1,l2) <- splitFunTy_maybe l - , Just (w2,r1,r2) <- splitFunTy_maybe r + | Just (af1,w1,l1,l2) <- splitFunTy_maybe l + , Just (af2,w2,r1,r2) <- splitFunTy_maybe r + , af1==af2 , w1 `eqType` w2 = do r2' <- go l2 r2 r1' <- go l1 r1 - return (mkVisFunTy w1 r1' r2') + return (mkFunTy af1 w1 r1' r2') -- TyconApp Inductive case; this is the interesting bit. | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs @@ -1416,7 +1421,7 @@ isMonomorphicOnNonPhantomArgs ty , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args , tyv `notElem` phantom_vars] = all isMonomorphicOnNonPhantomArgs concrete_args - | Just (_, ty1, ty2) <- splitFunTy_maybe ty + | Just (_, _, ty1, ty2) <- splitFunTy_maybe ty = all isMonomorphicOnNonPhantomArgs [ty1,ty2] | otherwise = isMonomorphic ty diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index e578c25357..b59071d5f6 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -39,9 +39,10 @@ import GHC.Rename.Names ( gresFromAvails ) import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) import GHC.Driver.Env -import GHCi.RemoteTypes ( HValue ) -import GHC.Core.Type ( Type, eqType, mkTyConTy ) -import GHC.Core.TyCon ( TyCon ) +import GHCi.RemoteTypes ( HValue ) +import GHC.Core.Type ( Type, mkTyConTy ) +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCon ( TyCon ) import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Types.Name ( Name, nameModule_maybe ) diff --git a/compiler/GHC/Settings/Constants.hs b/compiler/GHC/Settings/Constants.hs index 95dfe6a177..f2ceea8517 100644 --- a/compiler/GHC/Settings/Constants.hs +++ b/compiler/GHC/Settings/Constants.hs @@ -17,8 +17,8 @@ mAX_TUPLE_SIZE = 64 -- Should really match the number mAX_CTUPLE_SIZE :: Int -- Constraint tuples mAX_CTUPLE_SIZE = 64 -- Should match the number of decls in GHC.Classes -mAX_SUM_SIZE :: Int -mAX_SUM_SIZE = 64 +mAX_SUM_SIZE :: Int -- We use 6 bits to record sum size, +mAX_SUM_SIZE = 63 -- so max sum size is 63. Sadly inconsistent. -- | Default maximum depth for both class instance search and type family -- reduction. See also #5395. diff --git a/compiler/GHC/Stg/BcPrep.hs b/compiler/GHC/Stg/BcPrep.hs index d167a8c791..e9a3c88e34 100644 --- a/compiler/GHC/Stg/BcPrep.hs +++ b/compiler/GHC/Stg/BcPrep.hs @@ -144,7 +144,7 @@ newUnique = state $ newId :: Type -> BcPrepM Id newId ty = do uniq <- newUnique - return $ mkSysLocal prepFS uniq Many ty + return $ mkSysLocal prepFS uniq ManyTy ty prepFS :: FastString prepFS = fsLit "bcprep" diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index 8e16dd922c..0003150e19 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -282,7 +282,7 @@ withLiftedBndr abs_ids bndr inner = do -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least -- for arity information. = transferPolyIdInfo bndr (dVarSetElems abs_ids) - . mkSysLocal str uniq Many + . mkSysLocal str uniq ManyTy $ ty LiftM $ RWS.local (\e -> e diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index 8dfdeb607c..432c13fdf4 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -450,13 +450,13 @@ unariseMulti_maybe rho dc args ty_args -- Doesn't return void args. unariseRubbish_maybe :: Literal -> Maybe [OutStgArg] -unariseRubbish_maybe (LitRubbish rep) +unariseRubbish_maybe (LitRubbish torc rep) | [prep] <- preps , not (isVoidRep prep) = Nothing -- Single, non-void PrimRep. Nothing to do! | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase - = Just [ StgLitArg (LitRubbish (primRepToRuntimeRep prep)) + = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep)) | prep <- preps, not (isVoidRep prep) ] where preps = runtimeRepPrimRep (text "unariseRubbish_maybe") rep @@ -688,13 +688,13 @@ mkUbxSum dc ty_args args0 -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make" -- ubxSumRubbishArg :: SlotTy -> StgArg -ubxSumRubbishArg PtrLiftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID -ubxSumRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID -ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0) -ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) -ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) -ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) -ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish vec_rep) +ubxSumRubbishArg PtrLiftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID +ubxSumRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID +ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0) +ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) +ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) +ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) +ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish TypeLike vec_rep) where vec_rep = primRepToRuntimeRep (VecRep n e) -------------------------------------------------------------------------------- diff --git a/compiler/GHC/Stg/Utils.hs b/compiler/GHC/Stg/Utils.hs index 95f70a86ce..dc3e5b43a0 100644 --- a/compiler/GHC/Stg/Utils.hs +++ b/compiler/GHC/Stg/Utils.hs @@ -35,7 +35,7 @@ mkUnarisedIds :: MonadUnique m => FastString -> [UnaryType] -> m [Id] mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys mkUnarisedId :: MonadUnique m => FastString -> UnaryType -> m Id -mkUnarisedId s t = mkSysLocalM s Many t +mkUnarisedId s t = mkSysLocalM s ManyTy t -- Checks if id is a top level error application. -- isErrorAp_maybe :: Id -> @@ -72,8 +72,7 @@ mkStgAltTypeFromStgAlts bndr alts prim_reps = typePrimRep bndr_ty _is_poly_alt_tycon tc - = isFunTyCon tc - || isPrimTyCon tc -- "Any" is lifted but primitive + = isPrimTyCon tc -- "Any" is lifted but primitive || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict -- function application where argument has a -- type-family type diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs index 2ad1a8300f..bcf0990b49 100644 --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -1724,7 +1724,7 @@ pushLiteral padded lit = LitChar {} -> code WordRep LitNullAddr -> code AddrRep LitString {} -> code AddrRep - LitRubbish rep -> case runtimeRepPrimRep (text "pushLiteral") rep of + LitRubbish _ rep-> case runtimeRepPrimRep (text "pushLiteral") rep of [pr] -> code pr _ -> pprPanic "pushLiteral" (ppr lit) LitNumber nt _ -> case nt of diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index aced870367..f89c5304a1 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -36,6 +36,7 @@ import GHC.Types.Id import GHC.Cmm.Graph import GHC.Types.Name import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType ) import GHC.Builtin.Types.Prim import GHC.Types.Unique.FM import GHC.Types.Var.Env diff --git a/compiler/GHC/StgToCmm/Lit.hs b/compiler/GHC/StgToCmm/Lit.hs index 318c091a58..ac45c7af33 100644 --- a/compiler/GHC/StgToCmm/Lit.hs +++ b/compiler/GHC/StgToCmm/Lit.hs @@ -50,7 +50,7 @@ cgLit :: Literal -> FCode CmmExpr cgLit (LitString s) = CmmLit <$> newByteStringCLit s -- not unpackFS; we want the UTF-8 byte stream. -cgLit (LitRubbish rep) = +cgLit (LitRubbish _ rep) = case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] VoidRep -> panic "cgLit:VoidRep" -- ditto LiftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 0ca679901a..325ebde71c 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -886,7 +886,7 @@ showTypeCategory ty Just (tycon, _) -> let anyOf us = getUnique tycon `elem` us in case () of - _ | anyOf [funTyConKey] -> '>' + _ | anyOf [fUNTyConKey] -> '>' | anyOf [charTyConKey] -> 'C' | anyOf [charPrimTyConKey] -> 'c' | anyOf [doubleTyConKey] -> 'D' diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 8284aba4f7..4917b21a77 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -635,8 +635,8 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) -- is the case. | Just inst_ty <- lastMaybe inst_tys -> do - let via_kind = tcTypeKind via_ty - inst_ty_kind = tcTypeKind inst_ty + let via_kind = typeKind via_ty + inst_ty_kind = typeKind inst_ty mb_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust mb_match) @@ -747,7 +747,7 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind -- See Note [tc_args and tycon arity] (tc_args_to_keep, args_to_drop) = splitAt n_args_to_keep tc_args - inst_ty_kind = tcTypeKind (mkTyConApp tc tc_args_to_keep) + inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep) -- Match up the kinds, and apply the resulting kind substitution -- to the types. See Note [Unify kinds in deriving] @@ -756,6 +756,12 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind enough_args = n_args_to_keep >= 0 -- Check that the result really is well-kinded + ; traceTc "deriveTyData" $ + vcat [ text "class:" <+> ppr cls <+> dcolon <+> ppr (tyConKind (classTyCon cls)) + , text "cls_tys:" <+> ppr cls_tys + , text "tycon:" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) + , text "cls_arg:" <+> ppr (mkTyConApp tc tc_args_to_keep) <+> dcolon <+> ppr inst_ty_kind + , text "cls_arg_kind:" <+> ppr cls_arg_kind ] ; checkTc (enough_args && isJust mb_match) (TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $ DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep) @@ -797,9 +803,9 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind -- Perform an additional unification with the kind of the `via` -- type and the result of the previous kind unification. Just (ViaStrategy via_ty) -> do - let via_kind = tcTypeKind via_ty + let via_kind = typeKind via_ty inst_ty_kind - = tcTypeKind (mkTyConApp tc tc_args') + = typeKind (mkTyConApp tc tc_args') via_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust via_match) diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs index 4b111f7a41..9b5032531c 100644 --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -505,11 +505,11 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar -> Type -> (a, Bool) -- (result of type a, does type contain var) - go co ty | Just ty' <- tcView ty = go co ty' + go co ty | Just ty' <- coreView ty = go co ty' go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) go co (FunTy { ft_arg = x, ft_res = y, ft_af = af }) - | InvisArg <- af = go co y - | xc || yc = (caseFun xr yr,True) + | isInvisibleFunArg af = go co y + | xc || yc = (caseFun xr yr,True) where (xr,xc) = go (not co) x (yr,yc) = go co y go co (AppTy x y) | xc = (caseWrongArg, True) @@ -532,8 +532,8 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar -- actually needs. See #12399 (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) go co (ForAllTy (Bndr v vis) x) - | isVisibleArgFlag vis = panic "unexpected visible binder" - | v /= var && xc = (caseForAll v xr,True) + | isVisibleForAllTyFlag vis = panic "unexpected visible binder" + | v /= var && xc = (caseForAll v xr,True) where (xr,xc) = go co x go _ _ = (caseTrivial,False) diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 259d7ce20f..d4e4b87db8 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -72,6 +72,7 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Core.Type import GHC.Core.Class + import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) import GHC.Types.Var.Env import GHC.Utils.Misc diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index d35bac99a4..2b1bbb2bf2 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -24,18 +24,22 @@ where import GHC.Prelude hiding (head, init, last, tail) import GHC.Hs -import GHC.Core.Type import GHC.Tc.Utils.TcType import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Errors.Types +import GHC.Tc.Instance.Family + +import GHC.Core.Type import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) -import GHC.Tc.Instance.Family + import GHC.Unit.Module ( moduleName, moduleUnit , unitFS, getModule ) + import GHC.Iface.Env ( newGlobalBinder ) + import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader import GHC.Types.SourceText @@ -343,7 +347,7 @@ data GenericKind_DC = Gen0_DC | Gen1_DC TyVar gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC gk2gkDC Gen0 _ _ = Gen0_DC gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ) - $ getTyVar "gk2gkDC" last_dc_inst_univ + $ getTyVar last_dc_inst_univ where dc_inst_univs = dataConInstUnivs dc tc_args last_dc_inst_univ = assert (not (null dc_inst_univs)) $ diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index 5aa954ca4b..feba275d75 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -16,16 +16,6 @@ where import GHC.Prelude -import GHC.Data.Bag -import GHC.Types.Basic -import GHC.Core.Class -import GHC.Core.DataCon -import GHC.Utils.Error -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.Pair -import GHC.Builtin.Names import GHC.Tc.Deriv.Utils import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate @@ -35,21 +25,36 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint -import GHC.Core.Predicate import GHC.Tc.Utils.TcType -import GHC.Core.TyCon -import GHC.Core.TyCo.Ppr (pprTyVars) -import GHC.Core.Type import GHC.Tc.Solver import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor) -import GHC.Builtin.Types (typeToTypeKind) + +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr (pprTyVars) +import GHC.Core.Type +import GHC.Core.Predicate import GHC.Core.Unify (tcUnifyTy) + +import GHC.Data.Pair +import GHC.Builtin.Names +import GHC.Builtin.Types (typeToTypeKind) + +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain import GHC.Utils.Misc + +import GHC.Types.Basic import GHC.Types.Var import GHC.Types.Var.Set +import GHC.Data.Bag + import Control.Monad import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ask) @@ -236,7 +241,7 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys is_generic = main_cls `hasKey` genClassKey is_generic1 = main_cls `hasKey` gen1ClassKey -- is_functor_like: see Note [Inferring the instance context] - is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind + is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind || is_generic1 get_gen1_constraints :: @@ -288,7 +293,7 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys -- message which points out the kind mismatch. -- See Note [Inferring the instance context] mk_functor_like_constraints orig t_or_k cls - = map $ \ty -> let ki = tcTypeKind ty in + = map $ \ty -> let ki = typeKind ty in ( [ mk_cls_pred orig t_or_k cls ty , SimplePredSpec { sps_pred = mkPrimEqPred ki typeToTypeKind @@ -309,7 +314,7 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys -- and we need the Data constraints to typecheck the method extra_constraints | main_cls `hasKey` dataClassKey - , all (isLiftedTypeKind . tcTypeKind) rep_tc_args + , all (isLiftedTypeKind . typeKind) rep_tc_args = [ mk_cls_pred deriv_origin t_or_k main_cls ty | (t_or_k, ty) <- zip t_or_ks rep_tc_args] | otherwise diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index b6ad253ec1..e8e860e224 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -28,23 +28,8 @@ import GHC.Prelude import GHC.Data.Bag import GHC.Types.Basic -import GHC.Core.Class -import GHC.Core.DataCon -import GHC.Core.FamInstEnv -import GHC.Driver.Session -import GHC.Utils.Error -import GHC.Types.Fixity.Env (lookupFixity) -import GHC.Hs + import GHC.Tc.Utils.Instantiate -import GHC.Core.InstEnv -import GHC.Iface.Load (loadInterfaceForName) -import GHC.Unit.Module (getModule) -import GHC.Unit.Module.ModIface (mi_fix) -import GHC.Types.Name -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Builtin.Names -import GHC.Types.SrcLoc import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Deriv.Generics @@ -55,12 +40,33 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify (tcSubTypeSigma) import GHC.Tc.Utils.Zonk -import GHC.Builtin.Names.TH (liftClassKey) + +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.Type + +import GHC.Hs +import GHC.Driver.Session +import GHC.Unit.Module (getModule) +import GHC.Unit.Module.ModIface (mi_fix) + +import GHC.Types.Fixity.Env (lookupFixity) +import GHC.Iface.Load (loadInterfaceForName) +import GHC.Types.Name +import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Types.Var.Set +import GHC.Builtin.Names +import GHC.Builtin.Names.TH (liftClassKey) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Error + import Control.Monad.Trans.Reader import Data.Foldable (traverse_) import Data.Maybe diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 021d163d84..77e7b96f9c 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1,11 +1,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# LANGUAGE ParallelListComp #-} module GHC.Tc.Errors( reportUnsolved, reportAllUnsolved, warnAllUnsolved, @@ -60,8 +60,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.Coercion -import GHC.Core.TyCo.Ppr ( pprTyVars - ) +import GHC.Core.TyCo.Ppr ( pprTyVars ) import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.DataCon @@ -672,7 +671,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics is_user_type_error item _ = isUserTypeError (errorItemPred item) is_homo_equality _ (EqPred _ ty1 ty2) - = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 + = typeKind ty1 `tcEqType` typeKind ty2 is_homo_equality _ _ = False @@ -1098,7 +1097,7 @@ addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty -> do { -- See Note [Deferred errors for coercion holes] let co_var = coHoleCoVar hole ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm - ; fillCoercionHole hole (mkTcCoVarCo co_var) } } + ; fillCoercionHole hole (mkCoVarCo co_var) } } addDeferredBinding _ _ _ = return () -- Do not set any evidence for Given mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type -- of the error term @@ -1647,9 +1646,9 @@ mkEqErr_help :: SolverReportErrCtxt -> ErrorItem -> TcType -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) mkEqErr_help ctxt item ty1 ty2 - | Just casted_tv1 <- tcGetCastedTyVar_maybe ty1 + | Just casted_tv1 <- getCastedTyVar_maybe ty1 = mkTyVarEqErr ctxt item casted_tv1 ty2 - | Just casted_tv2 <- tcGetCastedTyVar_maybe ty2 + | Just casted_tv2 <- getCastedTyVar_maybe ty2 = mkTyVarEqErr ctxt item casted_tv2 ty1 | otherwise = do @@ -1803,7 +1802,7 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2 , Implic { ic_tclvl = lvl } <- implic = assertPpr (not (isTouchableMetaTyVar lvl tv1)) (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables] - tv_extra <- extraTyVarEqInfo (tv1, Just implic) ty2 + tv_extra <- extraTyVarEqInfo (tv1, Just implic) ty2 let tv_extra' = tv_extra { thisTyVarIsUntouchable = Just implic } msg = Mismatch { mismatchMsg = mismatch_msg @@ -1969,7 +1968,7 @@ extraTyVarEqInfo (tv1, mb_implic) ty2 , thisTyVarIsUntouchable = mb_implic , otherTy = ty2_info } where - ty_extra ty = case tcGetCastedTyVar_maybe ty of + ty_extra ty = case getCastedTyVar_maybe ty of Just (tv, _) -> Just <$> extraTyVarInfo tv Nothing -> return Nothing @@ -1991,7 +1990,7 @@ suggestAddSig ctxt ty1 _ty2 = Nothing where inferred_bndrs = - case tcGetTyVar_maybe ty1 of + case getTyVar_maybe ty1 of Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv _ -> [] @@ -2024,8 +2023,7 @@ mkMismatchMsg item ty1 ty2 = KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> (mkBasicMismatchMsg NoEA item ty1 ty2) { mismatch_whenMatching = Just $ WhenMatching cty1 cty2 sub_o mb_sub_t_or_k - , mismatch_mb_same_occ = mb_same_occ - } + , mismatch_mb_same_occ = mb_same_occ } _ -> (mkBasicMismatchMsg NoEA item ty1 ty2) { mismatch_mb_same_occ = mb_same_occ } diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 5590e29454..c2181e5c32 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -502,7 +502,7 @@ pprHoleFit _ (RawHoleFit sd) = sd pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = hang display 2 provenance where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap - where pprArg b arg = case binderArgFlag b of + where pprArg b arg = case binderFlag b of Specified -> text "@" <> pprParendType arg -- Do not print type application for inferred -- variables (#16456) @@ -520,11 +520,11 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = -- e.g. -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) -- into [m, a] - unwrapTypeVars :: Type -> [TyCoVarBinder] + unwrapTypeVars :: Type -> [ForAllTyBinder] unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of - Just (_, _, unfunned) -> unwrapTypeVars unfunned + Just (_, _, _, unfunned) -> unwrapTypeVars unfunned _ -> [] - where (vars, unforalled) = splitForAllTyCoVarBinders t + where (vars, unforalled) = splitForAllForAllTyBinders t holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches holeDisp = if sMs then holeVs else sep $ replicate (length hfMatches) $ text "_" @@ -917,7 +917,7 @@ tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates = _ -> True allConcrete = all notAbstract z_wrp_tys ; z_vars <- zonkTcTyVars ref_vars - ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars + ; let z_mtvs = mapMaybe getTyVar_maybe z_vars ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs ; allowAbstract <- goptM Opt_AbstractRefHoleFits ; if allowAbstract || (allFilled && allConcrete ) diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index ad23585fd0..d757d36115 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -25,8 +25,7 @@ module GHC.Tc.Errors.Ppr import GHC.Prelude import GHC.Builtin.Names -import GHC.Builtin.Types (boxedRepDataConTyCon) -import GHC.Builtin.Types.Prim (tYPETyCon) +import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon ) import GHC.Core.Coercion import GHC.Core.Unify ( tcMatchTys ) @@ -1018,6 +1017,7 @@ instance Diagnostic TcRnMessage where TcRnTypeDataForbids feature -> mkSimpleDecorated $ ppr feature <+> text "are not allowed in type data declarations." + TcRnIllegalNewtype con show_linear_types reason -> mkSimpleDecorated $ vcat [msg, additional] @@ -1036,7 +1036,8 @@ instance Diagnostic TcRnMessage where ppr con <+> dcolon <+> ppr (dataConDisplayType True con)) IsGADT -> (text "A newtype must not be a GADT", - ppr con <+> dcolon <+> pprWithExplicitKindsWhen sneaky_eq_spec (ppr $ dataConDisplayType show_linear_types con)) + ppr con <+> dcolon <+> pprWithExplicitKindsWhen sneaky_eq_spec + (ppr $ dataConDisplayType show_linear_types con)) HasConstructorContext -> (text "A newtype constructor must not have a context in its type", ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) @@ -1046,12 +1047,10 @@ instance Diagnostic TcRnMessage where HasStrictnessAnnotation -> (text "A newtype constructor must not have a strictness annotation", empty) - -- Is there an EqSpec involving an invisible binder? If so, print the - -- error message with explicit kinds. - invisible_binders = filter isInvisibleTyConBinder (tyConBinders $ dataConTyCon con) - sneaky_eq_spec - = any (\eq -> any (( == eqSpecTyVar eq) . binderVar) invisible_binders) - $ dataConEqSpec con + -- Is the data con a "covert" GADT? See Note [isCovertGadtDataCon] + -- in GHC.Core.DataCon + sneaky_eq_spec = isCovertGadtDataCon con + TcRnTypedTHWithPolyType ty -> mkSimpleDecorated $ vcat [ text "Illegal polytype:" <+> ppr ty @@ -2079,7 +2078,7 @@ format_frr_err ty = (bullet <+> ppr tidy_ty <+> dcolon <+> ppr tidy_ki) where (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty - tidy_ki = tidyType tidy_env (tcTypeKind ty) + tidy_ki = tidyType tidy_env (typeKind ty) pprField :: (FieldLabelString, TcType) -> SDoc pprField (f,ty) = ppr f <+> dcolon <+> ppr ty @@ -2378,8 +2377,8 @@ pprTcSolverReportMsg ctxt (ReportHoleError hole err) = pprHoleError ctxt hole err pprTcSolverReportMsg ctxt (CannotUnifyVariable - { mismatchMsg = msg - , cannotUnifyReason = reason }) + { mismatchMsg = msg + , cannotUnifyReason = reason }) = pprMismatchMsg ctxt msg $$ pprCannotUnifyVariableReason ctxt reason pprTcSolverReportMsg ctxt @@ -2578,7 +2577,7 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) , not (isTypeFamilyTyCon tc) = hang (text "GHC can't yet do polykinded") 2 (text "Typeable" <+> - parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) + parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) | otherwise = empty @@ -2731,13 +2730,14 @@ pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc pprMismatchMsg ctxt (BasicMismatch { mismatch_ea = ea , mismatch_item = item - , mismatch_ty1 = ty1 - , mismatch_ty2 = ty2 + , mismatch_ty1 = ty1 -- Expected + , mismatch_ty2 = ty2 -- Actual , mismatch_whenMatching = mb_match_txt , mismatch_mb_same_occ = same_occ_info }) - = addArising (errorItemCtLoc item) msg - $$ maybe empty (pprWhenMatching ctxt) mb_match_txt - $$ maybe empty pprSameOccInfo same_occ_info + = vcat [ addArising (errorItemCtLoc item) msg + , ea_extra + , maybe empty (pprWhenMatching ctxt) mb_match_txt + , maybe empty pprSameOccInfo same_occ_info ] where msg | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || @@ -2758,18 +2758,20 @@ pprMismatchMsg ctxt , nest padding $ text herald2 <> colon <+> ppr ty2 ] - want_ea = case ea of { NoEA -> False; EA {} -> True } - herald1 = conc [ "Couldn't match" , if is_repr then "representation of" else "" , if want_ea then "expected" else "" , what ] herald2 = conc [ "with" - , if is_repr then "that of" else "" + , if is_repr then "that of" else "" , if want_ea then ("actual " ++ what) else "" ] padding = length herald1 - length herald2 + (want_ea, ea_extra) + = case ea of + NoEA -> (False, empty) + EA mb_extra -> (True , maybe empty (pprExpectedActualInfo ctxt) mb_extra) is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False } what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel) @@ -2789,7 +2791,7 @@ pprMismatchMsg _ 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> quotes (ppr act)) where - kind_desc | tcIsConstraintKind exp = text "a constraint" + kind_desc | isConstraintLikeKind exp = text "a constraint" | Just arg <- kindRep_maybe exp -- TYPE t0 , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case True -> text "kind" <+> quotes (ppr exp) @@ -2799,53 +2801,78 @@ pprMismatchMsg _ pprMismatchMsg ctxt (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds , teq_mismatch_item = item - , teq_mismatch_ty1 = ty1 - , teq_mismatch_ty2 = ty2 - , teq_mismatch_expected = exp - , teq_mismatch_actual = act + , teq_mismatch_ty1 = ty1 -- These types are the actual types + , teq_mismatch_ty2 = ty2 -- that don't match; may be swapped + , teq_mismatch_expected = exp -- These are the context of + , teq_mismatch_actual = act -- the mis-match , teq_mismatch_what = mb_thing , teq_mb_same_occ = mb_same_occ }) - = (addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg) + = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg $$ maybe empty pprSameOccInfo mb_same_occ where - msg - | isUnliftedTypeKind act, isLiftedTypeKind exp - = sep [ text "Expecting a lifted type, but" - , thing_msg mb_thing (text "an") (text "unlifted") ] - | isLiftedTypeKind act, isUnliftedTypeKind exp - = sep [ text "Expecting an unlifted type, but" - , thing_msg mb_thing (text "a") (text "lifted") ] - | tcIsLiftedTypeKind exp - = maybe_num_args_msg $$ - sep [ text "Expected a type, but" - , case mb_thing of + msg | Just (torc, rep) <- sORTKind_maybe exp + = msg_for_exp_sort torc rep + + | Just nargs_msg <- num_args_msg + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig + = nargs_msg $$ pprMismatchMsg ctxt ea_msg + + | ea_looks_same ty1 ty2 exp act + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig + = pprMismatchMsg ctxt ea_msg + + | otherwise + = bale_out_msg + + -- bale_out_msg: the mismatched types are /inside/ exp and act + bale_out_msg = vcat errs + where + errs = case mk_ea_msg ctxt Nothing level orig of + Left ea_info -> pprMismatchMsg ctxt mismatch_err + : map (pprExpectedActualInfo ctxt) ea_info + Right ea_err -> [ pprMismatchMsg ctxt mismatch_err + , pprMismatchMsg ctxt ea_err ] + mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2 + + -- 'expected' is (TYPE rep) or (CONSTRAINT rep) + msg_for_exp_sort exp_torc exp_rep + | Just (act_torc, act_rep) <- sORTKind_maybe act + = -- (TYPE exp_rep) ~ (CONSTRAINT act_rep) etc + msg_torc_torc act_torc act_rep + | otherwise + = -- (TYPE _) ~ Bool, etc + maybe_num_args_msg $$ + sep [ text "Expected a" <+> ppr_torc exp_torc <> comma + , text "but" <+> case mb_thing of Nothing -> text "found something with kind" Just thing -> quotes (ppr thing) <+> text "has kind" , quotes (pprWithTYPE act) ] - | Just nargs_msg <- num_args_msg - , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = nargs_msg $$ pprMismatchMsg ctxt ea_msg - | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ - ea_looks_same ty1 ty2 exp act - , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = pprMismatchMsg ctxt ea_msg - | otherwise - = - -- The mismatched types are /inside/ exp and act - let mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2 - errs = case mk_ea_msg ctxt Nothing level orig of - Left ea_info -> pprMismatchMsg ctxt mismatch_err : map (pprExpectedActualInfo ctxt) ea_info - Right ea_err -> [ pprMismatchMsg ctxt mismatch_err, pprMismatchMsg ctxt ea_err ] - in vcat errs + where + msg_torc_torc act_torc act_rep + | exp_torc == act_torc + = msg_same_torc act_torc act_rep + | otherwise + = sep [ text "Expected a" <+> ppr_torc exp_torc <> comma + , text "but" <+> case mb_thing of + Nothing -> text "found a" + Just thing -> quotes (ppr thing) <+> text "is a" + <+> ppr_torc act_torc ] + + msg_same_torc act_torc act_rep + | Just exp_doc <- describe_rep exp_rep + , Just act_doc <- describe_rep act_rep + = sep [ text "Expected" <+> exp_doc <+> ppr_torc exp_torc <> comma + , text "but" <+> case mb_thing of + Just thing -> quotes (ppr thing) <+> text "is" + Nothing -> text "got" + <+> act_doc <+> ppr_torc act_torc ] + msg_same_torc _ _ = bale_out_msg ct_loc = errorItemCtLoc item orig = errorItemOrigin item level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel - thing_msg (Just thing) _ levity = quotes (ppr thing) <+> text "is" <+> levity - thing_msg Nothing an levity = text "got" <+> an <+> levity <+> text "type" - num_args_msg = case level of KindLevel | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) @@ -2865,7 +2892,34 @@ pprMismatchMsg ctxt maybe_num_args_msg = num_args_msg `orElse` empty - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty + count_args ty = count isVisiblePiTyBinder $ fst $ splitPiTys ty + + ppr_torc TypeLike = text "type"; + ppr_torc ConstraintLike = text "constraint" + + describe_rep :: RuntimeRepType -> Maybe SDoc + -- describe_rep IntRep = Just "an IntRep" + -- describe_rep (BoxedRep Lifted) = Just "a lifted" + -- etc + describe_rep rep + | Just (rr_tc, rr_args) <- splitRuntimeRep_maybe rep + = case rr_args of + [lev_ty] | rr_tc `hasKey` boxedRepDataConKey + , Just lev <- levityType_maybe lev_ty + -> case lev of + Lifted -> Just (text "a lifted") + Unlifted -> Just (text "a boxed unlifted") + [] | rr_tc `hasKey` tupleRepDataConTyConKey -> Just (text "a zero-bit") + | starts_with_vowel rr_occ -> Just (text "an" <+> text rr_occ) + | otherwise -> Just (text "a" <+> text rr_occ) + where + rr_occ = occNameString (getOccName rr_tc) + + _ -> Nothing -- Must be TupleRep [r1..rn] + | otherwise = Nothing + + starts_with_vowel (c:_) = c `elem` "AEIOU" + starts_with_vowel [] = False pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) = main_msg $$ @@ -3140,9 +3194,9 @@ pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = || not (cty1 `pickyEqType` cty2) then vcat [ hang (text "When matching" <+> sub_whats) 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (tcTypeKind cty1) + ppr (typeKind cty1) , ppr cty2 <+> dcolon <+> - ppr (tcTypeKind cty2) ]) + ppr (typeKind cty2) ]) , supplementary ] else text "When matching the kind of" <+> quotes (ppr cty1) where @@ -3242,7 +3296,7 @@ pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_sko hang (text "Found extra-constraints wildcard standing for") 2 (quotes $ pprType hole_ty) -- always kind constraint - hole_kind = tcTypeKind hole_ty + hole_kind = typeKind hole_ty pp_hole_type_with_kind | isLiftedTypeKind hole_kind @@ -3526,10 +3580,11 @@ tidySigSkol env cx ty tv_prs where (env', tv') = tidy_tv_bndr env tv - tidy_ty env ty@(FunTy InvisArg w arg res) -- Look under c => t - = ty { ft_mult = tidy_ty env w, - ft_arg = tidyType env arg, - ft_res = tidy_ty env res } + tidy_ty env ty@(FunTy af w arg res) -- Look under c => t + | isInvisibleFunArg af + = ty { ft_mult = tidy_ty env w + , ft_arg = tidyType env arg + , ft_res = tidy_ty env res } tidy_ty env ty = tidyType env ty @@ -3772,7 +3827,7 @@ expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) -- -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) + tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` coreView t) -- Drop the type pairs until types in a pair look alike (i.e. the outer -- constructors are the same). diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 2baccd1ee1..6a99ac1ce5 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -3288,8 +3288,8 @@ data TcSolverReportMsg -- | Cannot unify a variable, because of a type mismatch. | CannotUnifyVariable - { mismatchMsg :: MismatchMsg - , cannotUnifyReason :: CannotUnifyVariableReason } + { mismatchMsg :: MismatchMsg + , cannotUnifyReason :: CannotUnifyVariableReason } -- | A mismatch between two types. | Mismatch @@ -3308,6 +3308,11 @@ data TcSolverReportMsg -- -- Test cases: none. | BlockedEquality ErrorItem + -- These are for the "blocked" equalities, as described in + -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical, + -- wrinkle (2). There should always be another unsolved wanted around, + -- which will ordinarily suppress this message. But this can still be printed out + -- with -fdefer-type-errors (sigh), so we must produce a message. -- | Something was not applied to sufficiently many arguments. -- @@ -3388,7 +3393,7 @@ data MismatchMsg -- 3 + 3# -- can't match a lifted type with an unlifted type -- -- Test cases: T1396, T8263, ... - BasicMismatch -- SLD TODO rename this + BasicMismatch { mismatch_ea :: MismatchEA -- ^ Should this be phrased in terms of expected vs actual? , mismatch_item :: ErrorItem -- ^ The constraint in which the mismatch originated. , mismatch_ty1 :: Type -- ^ First type (the expected type if if mismatch_ea is True) @@ -3438,6 +3443,9 @@ data MismatchMsg } deriving Generic +-- | Construct a basic mismatch message between two types. +-- +-- See 'pprMismatchMsg' for how such a message is displayed to users. mkBasicMismatchMsg :: MismatchEA -> ErrorItem -> Type -> Type -> MismatchMsg mkBasicMismatchMsg ea item ty1 ty2 = BasicMismatch @@ -3489,6 +3497,8 @@ data CannotUnifyVariableReason | RepresentationalEq TyVarInfo (Maybe CoercibleMsg) deriving Generic +-- | Report a mismatch error without any extra +-- information. mkPlainMismatchMsg :: MismatchMsg -> TcSolverReportMsg mkPlainMismatchMsg msg = Mismatch diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index b420cf8c9e..c44fb65a29 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -40,6 +40,7 @@ import GHC.Core.TyCo.Ppr import GHC.Core.TyCo.Subst (substTyWithInScope) import GHC.Core.TyCo.FVs( shallowTyCoVarsOfType ) import GHC.Core.Type +import GHC.Core.Coercion import GHC.Tc.Types.Evidence import GHC.Types.Var.Set import GHC.Builtin.PrimOps( tagToEnumKey ) @@ -544,7 +545,7 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args HsUnboundVar {} -> True _ -> False - inst_all, inst_inferred, inst_none :: ArgFlag -> Bool + inst_all, inst_inferred, inst_none :: ForAllTyFlag -> Bool inst_all (Invisible {}) = True inst_all Required = False @@ -554,7 +555,7 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args inst_none _ = False - inst_fun :: [HsExprArg 'TcpRn] -> ArgFlag -> Bool + inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool inst_fun [] | inst_final = inst_all | otherwise = inst_none -- Using `inst_none` for `:type` avoids @@ -573,7 +574,7 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args -- go: If fun_ty=kappa, look it up in Theta go delta acc so_far fun_ty args - | Just kappa <- tcGetTyVar_maybe fun_ty + | Just kappa <- getTyVar_maybe fun_ty , kappa `elemVarSet` delta = do { cts <- readMetaTyVar kappa ; case cts of @@ -624,7 +625,7 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args -- Rule IVAR from Fig 4 of the QL paper: go1 delta acc so_far fun_ty args@(EValArg {} : _) - | Just kappa <- tcGetTyVar_maybe fun_ty + | Just kappa <- getTyVar_maybe fun_ty , kappa `elemVarSet` delta = -- Function type was of form f :: forall a b. t1 -> t2 -> b -- with 'b', one of the quantified type variables, in the corner @@ -651,8 +652,8 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args ; let delta' = delta `extendVarSetList` (res_nu:arg_nus) arg_tys = mkTyVarTys arg_nus res_ty = mkTyVarTy res_nu - fun_ty' = mkVisFunTys (zipWithEqual "tcInstFun" mkScaled mults arg_tys) res_ty - co_wrap = mkWpCastN (mkTcGReflLeftCo Nominal fun_ty' kind_co) + fun_ty' = mkScaledFunTys (zipWithEqual "tcInstFun" mkScaled mults arg_tys) res_ty + co_wrap = mkWpCastN (mkGReflLeftCo Nominal fun_ty' kind_co) acc' = addArgWrap co_wrap acc -- Suppose kappa :: kk -- Then fun_ty :: kk, fun_ty' :: Type, kind_co :: Type ~ kk @@ -716,7 +717,7 @@ tcVTA :: TcType -- Function type -- The function type has already had its Inferred binders instantiated tcVTA fun_ty hs_ty | Just (tvb, inner_ty) <- tcSplitForAllTyVarBinder_maybe fun_ty - , binderArgFlag tvb == Specified + , binderFlag tvb == Specified -- It really can't be Inferred, because we've just -- instantiated those. But, oddly, it might just be Required. -- See Note [Required quantifiers in the type of a term] @@ -731,11 +732,12 @@ tcVTA fun_ty hs_ty insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty -- NB: tv and ty_arg have the same kind, so this -- substitution is kind-respecting - ; traceTc "VTA" (vcat [ppr tv, debugPprType kind - , debugPprType ty_arg - , debugPprType (tcTypeKind ty_arg) - , debugPprType inner_ty - , debugPprType insted_ty ]) + ; traceTc "VTA" (vcat [ text "fun_ty" <+> ppr fun_ty + , text "tv" <+> ppr tv <+> dcolon <+> debugPprType kind + , text "ty_arg" <+> debugPprType ty_arg <+> dcolon + <+> debugPprType (typeKind ty_arg) + , text "inner_ty" <+> debugPprType inner_ty + , text "insted_ty" <+> debugPprType insted_ty ]) ; return (ty_arg, insted_ty) } | otherwise @@ -758,7 +760,7 @@ whose first argument is Required We want to reject this type application to Int, but in earlier GHCs we had an ASSERT that Required could not occur here. -The ice is thin; c.f. Note [No Required TyCoBinder in terms] +The ice is thin; c.f. Note [No Required PiTyBinder in terms] in GHC.Core.TyCo.Rep. Note [VTA for out-of-scope functions] @@ -876,7 +878,7 @@ quickLookArg delta larg (Scaled _ arg_ty) -- This top-level zonk step, which is the reason -- we need a local 'go' loop, is subtle -- See Section 9 of the QL paper - | Just kappa <- tcGetTyVar_maybe arg_ty + | Just kappa <- getTyVar_maybe arg_ty , kappa `elemVarSet` delta = do { info <- readMetaTyVar kappa ; case info of @@ -990,8 +992,8 @@ qlUnify delta ty1 ty2 -- Now, and only now, expand synonyms go bvs rho1 rho2 - | Just rho1 <- tcView rho1 = go bvs rho1 rho2 - | Just rho2 <- tcView rho2 = go bvs rho1 rho2 + | Just rho1 <- coreView rho1 = go bvs rho1 rho2 + | Just rho2 <- coreView rho2 = go bvs rho1 rho2 go bvs (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2 @@ -1001,25 +1003,25 @@ qlUnify delta ty1 ty2 -- Decompose (arg1 -> res1) ~ (arg2 -> res2) -- and (c1 => res1) ~ (c2 => res2) - -- But for the latter we only learn instantiation info from t1~t2 + -- But for the latter we only learn instantiation info from res1~res2 -- We look at the multiplicity too, although the chances of getting -- impredicative instantiation info from there seems...remote. go bvs (FunTy { ft_af = af1, ft_arg = arg1, ft_res = res1, ft_mult = mult1 }) (FunTy { ft_af = af2, ft_arg = arg2, ft_res = res2, ft_mult = mult2 }) - | af1 == af2 - = do { when (af1 == VisArg) $ - do { go bvs arg1 arg2; go bvs mult1 mult2 } + | af1 == af2 -- Match the arrow TyCon + = do { when (isVisibleFunArg af1) (go bvs arg1 arg2) + ; when (isFUNArg af1) (go bvs mult1 mult2) ; go bvs res1 res2 } -- ToDo: c.f. Tc.Utils.unify.uType, -- which does not split FunTy here - -- Also NB tcRepSplitAppTy here, which does not split (c => t) + -- Also NB tcSplitAppTyNoView here, which does not split (c => t) go bvs (AppTy t1a t1b) ty2 - | Just (t2a, t2b) <- tcRepSplitAppTy_maybe ty2 + | Just (t2a, t2b) <- tcSplitAppTyNoView_maybe ty2 = do { go bvs t1a t2a; go bvs t1b t2b } go bvs ty1 (AppTy t2a t2b) - | Just (t1a, t1b) <- tcRepSplitAppTy_maybe ty1 + | Just (t1a, t1b) <- tcSplitAppTyNoView_maybe ty1 = do { go bvs t1a t2a; go bvs t1b t2b } go (bvs1, bvs2) (ForAllTy bv1 ty1) (ForAllTy bv2 ty2) @@ -1215,7 +1217,7 @@ tcTagToEnum tc_fun fun_ctxt tc_args res_ty check_enumeration res_ty rep_tc ; let rep_ty = mkTyConApp rep_tc rep_args tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun - df_wrap = mkWpCastR (mkTcSymCo coi) + df_wrap = mkWpCastR (mkSymCo coi) ; tc_expr <- rebuildHsApps tc_fun' fun_ctxt [val_arg] res_ty ; return (mkHsWrap df_wrap tc_expr) }}}}} diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index 6e4166d36d..65202cdeb2 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -33,6 +33,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence import GHC.Core.Multiplicity +import GHC.Core.Coercion import GHC.Types.Id( mkLocalId ) import GHC.Tc.Utils.Instantiate import GHC.Builtin.Types @@ -104,8 +105,7 @@ tcProc pat cmd@(L loc (HsCmdTop names _)) exp_ty ; (pat', cmd') <- newArrowScope $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty) $ tcCmdTop cmd_env names' cmd (unitTy, res_ty) - ; let res_co = mkTcTransCo co - (mkTcAppCo co1 (mkTcNomReflCo res_ty)) + ; let res_co = co `mkTransCo` mkAppCo co1 (mkNomReflCo res_ty) ; return (pat', cmd', res_co) } {- @@ -383,11 +383,11 @@ tcCmdMatchLambda env matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType) matchExpectedCmdArgs 0 ty - = return (mkTcNomReflCo ty, [], ty) + = return (mkNomReflCo ty, [], ty) matchExpectedCmdArgs n ty = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 - ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } + ; return (mkTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } {- ************************************************************************ @@ -424,7 +424,8 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_n , recS_rec_ids = rec_names }) res_ty thing_inside = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith (\n p -> mkLocalId n Many p) tup_names tup_elt_tys -- Many because it's a recursive definition + ; let tup_ids = zipWith (\n p -> mkLocalId n ManyTy p) tup_names tup_elt_tys + -- Many because it's a recursive definition ; tcExtendIdEnv tup_ids $ do { (stmts', tup_rets) <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 10e665051d..e430584931 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -32,6 +32,7 @@ import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) import GHC.Driver.Session import GHC.Data.FastString import GHC.Hs + import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) @@ -42,46 +43,53 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Solver import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint -import GHC.Core.Predicate -import GHC.Core.TyCo.Ppr( pprTyVars ) + import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType +import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Validity (checkValidType) + +import GHC.Core.Predicate import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) -import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) import GHC.Core.Class ( Class ) -import GHC.Tc.Utils.TcType +import GHC.Core.Coercion( mkSymCo ) import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) -import GHC.Builtin.Types ( mkBoxedTupleTy ) +import GHC.Core.TyCo.Ppr( pprTyVars ) + +import GHC.Builtin.Types ( mkConstraintTupleTy ) import GHC.Builtin.Types.Prim +import GHC.Unit.Module + import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Var.Env( TidyEnv, TyVarEnv, mkVarEnv, lookupVarEnv ) -import GHC.Unit.Module import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.SrcLoc -import GHC.Data.Bag + import GHC.Utils.Error -import GHC.Data.Graph.Directed -import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Types.Basic import GHC.Types.CompleteMatch import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Names( ipClassName ) -import GHC.Tc.Validity (checkValidType) import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.Unique.Set import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.Bag +import GHC.Data.Graph.Directed +import GHC.Data.Maybe + import Control.Monad import Data.Foldable (find) @@ -540,7 +548,7 @@ recoveryCode binder_names sig_fn , Just poly_id <- completeSigPolyId_maybe sig = poly_id | otherwise - = mkLocalId name Many forall_a_a + = mkLocalId name ManyTy forall_a_a forall_a_a :: TcType -- At one point I had (forall r (a :: TYPE r). a), but of course @@ -904,7 +912,7 @@ mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mo -- do this check; otherwise (#14000) we may report an ambiguity -- error for a rather bogus type. - ; return (mkLocalId poly_name Many inferred_poly_ty) } + ; return (mkLocalId poly_name ManyTy inferred_poly_ty) } chooseInferredQuantifiers :: WantedConstraints -- residual constraints @@ -1006,12 +1014,12 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs -- NB: my_theta already includes all the annotated constraints ; diff_theta <- findInferredDiff annotated_theta my_theta - ; case tcGetCastedTyVar_maybe wc_var_ty of + ; case getCastedTyVar_maybe wc_var_ty of -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc. -- So, to make the kinds work out, we reverse the cast here. - Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mk_ctuple diff_theta - `mkCastTy` mkTcSymCo wc_co) + Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta + `mkCastTy` mkSymCo wc_co) Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) ; traceTc "completeTheta" $ @@ -1037,13 +1045,9 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic) , let residual_pred = ctPred residual_ct , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ] - , Just lhs_tv <- [ tcGetTyVar_maybe lhs ] + , Just lhs_tv <- [ getTyVar_maybe lhs ] , lhs_tv == tv ] - mk_ctuple preds = mkBoxedTupleTy preds - -- Hack alert! See GHC.Tc.Gen.HsType: - -- Note [Extra-constraint holes in partial type signatures] - chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) })) = pprPanic "chooseInferredQuantifiers" (ppr sig) @@ -1261,7 +1265,7 @@ tcMonoBinds is_rec sig_fn no_gen = setSrcSpanA b_loc $ do { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) -> -- See Note [fixM for rhs_ty in tcMonoBinds] - do { mono_id <- newLetBndr no_gen name Many rhs_ty + do { mono_id <- newLetBndr no_gen name ManyTy rhs_ty ; (matches', rhs_ty') <- tcInfer $ \ exp_ty -> tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ @@ -1441,7 +1445,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name | otherwise -- No type signature = do { mono_ty <- newOpenFlexiTyVarTy - ; mono_id <- newLetBndr no_gen name Many mono_ty + ; mono_id <- newLetBndr no_gen name ManyTy mono_ty -- This ^ generates a binder with Many multiplicity because all -- let/where-binders are unrestricted. When we introduce linear let -- binders, we will need to retrieve the multiplicity information. @@ -1512,7 +1516,7 @@ newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) | CompleteSig { sig_bndr = poly_id } <- id_sig = addInlinePrags poly_id (lookupPragEnv prags name) newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) - = newLetBndr no_gen name Many tau + = newLetBndr no_gen name ManyTy tau -- Binders with a signature are currently always of multiplicity -- Many. Because they come either from toplevel, let, or where -- declarations. Which are all unrestricted currently. diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs index 9027337b83..7b8cb362e4 100644 --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -12,7 +12,8 @@ import GHC.Prelude import GHC.Hs import GHC.Core.Class -import GHC.Core.Type ( typeKind ) +import GHC.Core.Type( typeKind ) + import GHC.Types.Var( tyVarKind ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index c2a680b3d4..8ab5ad3d0d 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -69,6 +69,7 @@ import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Core.TyCon import GHC.Core.Type +import GHC.Core.Coercion( mkSymCo ) import GHC.Tc.Types.Evidence import GHC.Builtin.Types import GHC.Builtin.Names @@ -331,7 +332,7 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys) + act_res_ty = mkScaledFunTys missing_tys (mkTupleTy1 boxity arg_tys) ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) @@ -648,7 +649,7 @@ arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType arithSeqEltType Nothing res_ty = do { res_ty <- expTypeToType res_ty ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; return (mkWpCastN coi, One, elt_ty, Nothing) } + ; return (mkWpCastN coi, OneTy, elt_ty, Nothing) } arithSeqEltType (Just fl) res_ty = do { ((elt_mult, elt_ty), fl') <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ @@ -847,7 +848,7 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside ; (list_co, elt_ty) <- matchExpectedListTy rho_ty -- list_co :: [elt_ty] ~N rho_ty ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } + ; return (result, mkWpCastN (mkSymCo list_co) <.> inst_wrap) } tc_syn_arg _ (SynFun {}) _ = pprPanic "tcSynArgA hits a SynFun" (ppr orig) tc_syn_arg res_ty (SynType the_ty) thing_inside @@ -1182,8 +1183,8 @@ desugarRecordUpd record_expr rbnds res_ty -- the record to disambiguate its fields, so we must infer the record -- type here before we can desugar. See Wrinkle [Disambiguating fields] -- in Note [Record Updates]. - ; ((_, record_rho), _lie) <- captureConstraints $ -- see (1) below - tcScalingUsage Many $ -- see (2) below + ; ((_, record_rho), _lie) <- captureConstraints $ -- see (1) below + tcScalingUsage ManyTy $ -- see (2) below tcInferRho record_expr -- (1) @@ -1593,7 +1594,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name) - Many field_ty (locA loc) + ManyTy field_ty (locA loc) -- Yuk: the field_id has the *unique* of the selector Id -- (so we can find it easily) -- but is a LocalId with the appropriate type of the RHS diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index d31cae7820..e4b741f13a 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -44,29 +44,35 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Expr import GHC.Tc.Utils.Env - +import GHC.Tc.Utils.TcType import GHC.Tc.Instance.Family + import GHC.Core.FamInstEnv import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.Type import GHC.Core.Multiplicity +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCon.RecWalk + import GHC.Types.ForeignCall -import GHC.Utils.Error import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.TyCon.RecWalk -import GHC.Tc.Utils.TcType +import GHC.Types.SrcLoc + import GHC.Builtin.Names +import GHC.Builtin.Types.Prim( isArrowTyCon ) + import GHC.Driver.Session import GHC.Driver.Backend + +import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Platform -import GHC.Types.SrcLoc + import GHC.Data.Bag import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt @@ -122,13 +128,13 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0 where go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction go role rec_nts ty - | Just ty' <- tcView ty -- Expand synonyms + | Just ty' <- coreView ty -- Expand synonyms = go role rec_nts ty' | Just (tc, tys) <- splitTyConApp_maybe ty = go_tc_app role rec_nts tc tys - | (bndrs, inner_ty) <- splitForAllTyCoVarBinders ty + | (bndrs, inner_ty) <- splitForAllForAllTyBinders ty , not (null bndrs) = do redn <- go role rec_nts inner_ty return $ mkHomoForAllRedn bndrs redn @@ -139,9 +145,13 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0 go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type] -> WriterT (Bag GlobalRdrElt) TcM Reduction go_tc_app role rec_nts tc tys + | isArrowTyCon tc -- Recurse through arrows, or at least the top + = children_only -- level arrows. Remember, the default case is + -- "don't recurse" (see last eqn for go_tc_app) + + | tc_key `elem` [ioTyConKey, funPtrTyConKey] -- We don't want to look through the IO newtype, even if it is -- in scope, so we have a special case for it: - | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] = children_only | isNewTyCon tc -- Expand newtypes @@ -244,10 +254,17 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty ; let - -- Drop the foralls before inspecting the - -- structure of the foreign type. - (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty) - id = mkLocalId nm Many sig_ty + -- Drop the foralls before inspecting the + -- structure of the foreign type. + -- Use splitFunTys, which splits (=>) as well as (->) + -- so that for foreign import foo :: Eq a => a -> blah + -- we get "unacceptable argument Eq a" rather than + -- "unacceptable result Eq a => a -> blah" + -- Not a big deal. We could make a better error message specially + -- for overloaded functions, but doesn't seem worth it + (arg_tys, res_ty) = splitFunTys (dropForAlls norm_sig_ty) + + id = mkLocalId nm ManyTy sig_ty -- Use a LocalId to obey the invariant that locally-defined -- things are LocalIds. However, it does not need zonking, -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it). @@ -271,7 +288,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh l@(CLabel = do checkCg (Right idecl) backendValidityOfCImport -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) - check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) + check (isFFILabelTy (mkScaledFunTys arg_tys res_ty)) (TcRnIllegalForeignType Nothing) cconv' <- checkCConv (Right idecl) cconv return (CImport src (L lc cconv') safety mh l) @@ -304,7 +321,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh addErrTc (TcRnIllegalForeignType Nothing AtLeastOneArgExpected) (Scaled arg1_mult arg1_ty:arg_tys) -> do dflags <- getDynFlags - let curried_res_ty = mkVisFunTys arg_tys res_ty + let curried_res_ty = mkScaledFunTys arg_tys res_ty checkNoLinearFFI arg1_mult check (isFFIDynTy curried_res_ty arg1_ty) (TcRnIllegalForeignType (Just Arg)) @@ -442,8 +459,8 @@ checkForeignArgs pred tys = mapM_ go tys check (pred ty) (TcRnIllegalForeignType (Just Arg)) checkNoLinearFFI :: Mult -> TcM () -- No linear types in FFI (#18472) -checkNoLinearFFI Many = return () -checkNoLinearFFI _ = addErrTc $ TcRnIllegalForeignType (Just Arg) +checkNoLinearFFI ManyTy = return () +checkNoLinearFFI _ = addErrTc $ TcRnIllegalForeignType (Just Arg) LinearTypesNotAllowed ------------ Checking result types for foreign calls ---------------------- @@ -464,7 +481,7 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty -- We disallow nested foralls in foreign types -- (at least, for the time being). See #16702. - | tcIsForAllTy ty + | isForAllTy ty = addErrTc $ TcRnIllegalForeignType (Just Result) UnexpectedNestedForall -- Case for non-IO result type with FFI Import diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index b01c7ccb5d..99b09487b1 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -35,20 +35,20 @@ module GHC.Tc.Gen.Head import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC ) +import GHC.Prelude +import GHC.Hs + import GHC.Tc.Gen.HsType +import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) + import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan ) import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify -import GHC.Types.Basic -import GHC.Types.Error import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Core.UsageEnv ( unitUE ) -import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Unit.Module ( getModule ) import GHC.Tc.Errors.Types import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) @@ -56,35 +56,41 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType -import GHC.Hs +import GHC.Tc.Types.Evidence import GHC.Hs.Syn.Type -import GHC.Types.Id -import GHC.Types.Id.Info + +import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Core.UsageEnv ( unitUE ) import GHC.Core.PatSyn( PatSyn ) import GHC.Core.ConLike( ConLike(..) ) import GHC.Core.DataCon -import GHC.Types.Name -import GHC.Types.Name.Reader import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.Type -import GHC.Tc.Types.Evidence + +import GHC.Types.Var( isInvisibleFunArg ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Error + import GHC.Builtin.Types( multiplicityTy ) import GHC.Builtin.Names import GHC.Builtin.Names.TH( liftStringName, liftName ) + import GHC.Driver.Env import GHC.Driver.Session -import GHC.Types.SrcLoc import GHC.Utils.Misc -import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import Control.Monad -import Data.Function +import GHC.Data.Maybe +import Control.Monad -import GHC.Prelude {- ********************************************************************* @@ -591,7 +597,7 @@ tcRemainingValArgs applied_args app_res_rho fun = case fun of where - rem_arg_tys :: [(Scaled Type, AnonArgFlag)] + rem_arg_tys :: [(Scaled Type, FunTyFlag)] rem_arg_tys = getRuntimeArgTys app_res_rho -- We do not need to zonk app_res_rho first, because the number of arrows -- in the (possibly instantiated) inferred type of the function will @@ -606,7 +612,7 @@ tcRemainingValArgs applied_args app_res_rho fun = case fun of -- value argument index, starting from 1 -- used to count up to the arity to ensure that -- we don't check too many argument types - -> [(Scaled Type, AnonArgFlag)] + -> [(Scaled Type, FunTyFlag)] -- run-time argument types -> TcM () tc_rem_args _ i_val _ @@ -617,9 +623,9 @@ tcRemainingValArgs applied_args app_res_rho fun = case fun of -- than the number of arguments apparent from the type. = pprPanic "tcRemainingValArgs" debug_msg tc_rem_args i_visval !i_val ((Scaled _ arg_ty, af) : tys) - = do { let (i_visval', arg_pos) = - case af of { InvisArg -> ( i_visval , ArgPosInvis ) - ; VisArg -> ( i_visval + 1, ArgPosVis i_visval ) } + = do { let (i_visval', arg_pos) + | isInvisibleFunArg af = ( i_visval , ArgPosInvis ) + | otherwise = ( i_visval + 1, ArgPosVis i_visval ) frr_ctxt = FRRNoBindingResArg rep_poly_fun arg_pos ; hasFixedRuntimeRep_syntactic frr_ctxt arg_ty -- Why is this a syntactic check? See Wrinkle [Syntactic check] in @@ -948,7 +954,7 @@ tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) ; let poly_wrap = wrap <.> mkWpTyLams qtvs - <.> mkWpLams givens + <.> mkWpEvLams givens <.> mkWpLet ev_binds ; return (mkLHsWrap poly_wrap expr', my_sigma) } @@ -1118,7 +1124,7 @@ tc_infer_id id_name check_local_id :: Id -> TcM () check_local_id id = do { checkThLocalId id - ; tcEmitBindingUsage $ unitUE (idName id) One } + ; tcEmitBindingUsage $ unitUE (idName id) OneTy } check_naughty :: OccName -> TcId -> TcM () check_naughty lbl id @@ -1147,14 +1153,14 @@ tcInferDataCon con ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys) , mkInvisForAllTys tvbs $ mkPhiTy full_theta $ - mkVisFunTys scaled_arg_tys res ) } + mkScaledFunTys scaled_arg_tys res ) } where linear_to_poly :: Scaled Type -> TcM (Scaled Type) -- linear_to_poly implements point (3,4) -- of Note [Typechecking data constructors] - linear_to_poly (Scaled One ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy - ; return (Scaled mul_var ty) } - linear_to_poly scaled_ty = return scaled_ty + linear_to_poly (Scaled OneTy ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy + ; return (Scaled mul_var ty) } + linear_to_poly scaled_ty = return scaled_ty tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType) tcInferPatSyn id_name ps diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index fa24c6286b..9d9f597db2 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -83,7 +83,6 @@ import GHC.Rename.Utils import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin -import GHC.Core.Predicate import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType @@ -92,13 +91,16 @@ import GHC.Tc.Utils.Unify import GHC.IfaceToCore import GHC.Tc.Solver import GHC.Tc.Utils.Zonk -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs, tcInstTypeBndrs ) + import GHC.Core.Type +import GHC.Core.Predicate +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr + import GHC.Builtin.Types.Prim import GHC.Types.Error import GHC.Types.Name.Env @@ -635,7 +637,7 @@ tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) tcHsDeriv hs_ty = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty ; let (tvs, pred) = splitForAllTyCoVars ty - (kind_args, _) = splitFunTys (tcTypeKind pred) + (kind_args, _) = splitFunTys (typeKind pred) ; case getClassPredTys_maybe pred of Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args) Nothing -> failWithTc $ TcRnIllegalDerivingItem hs_ty } @@ -1047,7 +1049,7 @@ tc_infer_hs_type mode (HsKindSig _ ty sig) -- -- See Note [Delaying modFinalizers in untyped splices]. tc_infer_hs_type mode (HsSpliceTy (HsUntypedSpliceTop _ ty) _) - = tc_infer_hs_type mode ty + = tc_infer_lhs_type mode ty tc_infer_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) = pprPanic "tc_infer_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s) @@ -1064,7 +1066,7 @@ tc_infer_hs_type _ (XHsType ty) (mkInScopeSetList $ map snd subst_prs) (listToUFM_Directly $ map (fmap mkTyVarTy) subst_prs) ty' = substTy subst ty - return (ty', tcTypeKind ty') + return (ty', typeKind ty') tc_infer_hs_type _ (HsExplicitListTy _ _ tys) | null tys -- this is so that we can use visible kind application with '[] @@ -1151,7 +1153,7 @@ tc_hs_type _ ty@(HsRecTy {}) _ tc_hs_type mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _) exp_kind = do addModFinalizersWithLclEnv mod_finalizers - tc_hs_type mode ty exp_kind + tc_lhs_type mode ty exp_kind tc_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tc_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s) @@ -1160,7 +1162,7 @@ tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind = tc_fun_type mode mult ty1 ty2 exp_kind tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind - | op `hasKey` funTyConKey + | op `hasKey` unrestrictedFunTyConKey = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind --------- Foralls @@ -1181,10 +1183,10 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind = tc_lhs_type mode rn_ty exp_kind -- See Note [Body kind of a HsQualTy] - | tcIsConstraintKind exp_kind + | isConstraintLikeKind exp_kind = do { ctxt' <- tc_hs_context mode ctxt ; ty' <- tc_lhs_type mode rn_ty constraintKind - ; return (mkPhiTy ctxt' ty') } + ; return (tcMkDFunPhiTy ctxt' ty') } | otherwise = do { ctxt' <- tc_hs_context mode ctxt @@ -1192,7 +1194,7 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind ; ek <- newOpenTypeKind -- The body kind (result of the function) can -- be TYPE r, for any r, hence newOpenTypeKind ; ty' <- tc_lhs_type mode rn_ty ek - ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty') + ; checkExpectedKind (unLoc rn_ty) (tcMkPhiTy ctxt' ty') liftedTypeKind exp_kind } --------- Lists, arrays, and tuples @@ -1278,8 +1280,8 @@ tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind constraintKind exp_kind } tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind - -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to - -- handle it in 'coreView' and 'tcView'. + -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't + -- have to handle it in 'coreView' = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind --------- Literals @@ -1313,12 +1315,12 @@ Note [Variable Specificity and Forall Visibility] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall binder. Furthermore, each invisible type variable binder also has a -Specificity. Together, these determine the variable binders (ArgFlag) for each +Specificity. Together, these determine the variable binders (ForAllTyFlag) for each variable in the generated ForAllTy type. This table summarises this relation: ---------------------------------------------------------------------------- -| User-written type HsForAllTelescope Specificity ArgFlag +| User-written type HsForAllTelescope Specificity ForAllTyFlag |--------------------------------------------------------------------------- | f :: forall a. type HsForAllInvis SpecifiedSpec Specified | f :: forall {a}. type HsForAllInvis InferredSpec Inferred @@ -1327,8 +1329,8 @@ This table summarises this relation: | This last form is nonsensical and is thus rejected. ---------------------------------------------------------------------------- -For more information regarding the interpretation of the resulting ArgFlag, see -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". +For more information regarding the interpretation of the resulting ForAllTyFlag, see +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". -} ------------------------------------------ @@ -1339,18 +1341,21 @@ tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> Tc -> TcM TcType tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of TypeLevel -> - do { arg_k <- newOpenTypeKind + do { traceTc "tc_fun_type" (ppr ty1 $$ ppr ty2) + ; arg_k <- newOpenTypeKind ; res_k <- newOpenTypeKind - ; ty1' <- tc_lhs_type mode ty1 arg_k - ; ty2' <- tc_lhs_type mode ty2 res_k + ; ty1' <- tc_lhs_type mode ty1 arg_k + ; ty2' <- tc_lhs_type mode ty2 res_k ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) + (tcMkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } KindLevel -> -- no representation polymorphism in kinds. yet. - do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind - ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind + do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind + ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) + (tcMkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } {- Note [Skolem escape and forall-types] @@ -1395,10 +1400,10 @@ Note that tupKindSort_maybe :: TcKind -> Maybe TupleSort tupKindSort_maybe k | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' - | Just k' <- tcView k = tupKindSort_maybe k' - | tcIsConstraintKind k = Just ConstraintTuple - | tcIsLiftedTypeKind k = Just BoxedTuple - | otherwise = Nothing + | Just k' <- coreView k = tupKindSort_maybe k' + | isConstraintKind k = Just ConstraintTuple + | tcIsLiftedTypeKind k = Just BoxedTuple + | otherwise = Nothing tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType tc_tuple rn_ty mode tup_sort tys exp_kind @@ -1502,7 +1507,7 @@ splitHsAppTys hs_ty is_app :: HsType GhcRn -> Bool is_app (HsAppKindTy {}) = True is_app (HsAppTy {}) = True - is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` funTyConKey) + is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` unrestrictedFunTyConKey) -- I'm not sure why this funTyConKey test is necessary -- Can it even happen? Perhaps for t1 `(->)` t2 -- but then maybe it's ok to treat that like a normal @@ -1568,12 +1573,12 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args go_init n fun all_args = go n fun empty_subst fun_ki all_args where - fun_ki = tcTypeKind fun - -- We do (tcTypeKind fun) here, even though the caller + fun_ki = typeKind fun + -- We do (typeKind fun) here, even though the caller -- knows the function kind, to absolutely guarantee -- INVARIANT for 'go' -- Note that in a typical application (F t1 t2 t3), - -- the 'fun' is just a TyCon, so tcTypeKind is fast + -- the 'fun' is just a TyCon, so typeKind is fast empty_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfType fun_ki @@ -1585,13 +1590,13 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args -> [LHsTypeArg GhcRn] -- Un-type-checked args -> TcM (TcType, TcKind) -- Result type and its kind -- INVARIANT: in any call (go n fun subst fun_ki args) - -- tcTypeKind fun = subst(fun_ki) + -- typeKind fun = subst(fun_ki) -- So the 'subst' and 'fun_ki' arguments are simply - -- there to avoid repeatedly calling tcTypeKind. + -- there to avoid repeatedly calling typeKind. -- -- Reason for INVARIANT: to support the Purely Kinded Type Invariant -- it's important that if fun_ki has a forall, then so does - -- (tcTypeKind fun), because the next thing we are going to do + -- (typeKind fun), because the next thing we are going to do -- is apply 'fun' to an argument type. -- Dispatch on all_args first, for performance reasons @@ -1608,16 +1613,16 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args case ki_binder of -- FunTy with PredTy on LHS, or ForAllTy with Inferred - Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki - Anon InvisArg _ -> instantiate ki_binder inner_ki + Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki + Anon _ af | isInvisibleFunArg af -> instantiate ki_binder inner_ki Named (Bndr _ Specified) -> -- Visible kind application do { traceTc "tcInferTyApps (vis kind app)" (vcat [ ppr ki_binder, ppr hs_ki_arg - , ppr (tyBinderType ki_binder) + , ppr (piTyBinderType ki_binder) , ppr subst ]) - ; let exp_kind = substTy subst $ tyBinderType ki_binder + ; let exp_kind = substTy subst $ piTyBinderType ki_binder ; arg_mode <- mkHoleMode KindLevel HM_VTA -- HM_VKA: see Note [Wildcards in visible kind application] ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $ @@ -1639,8 +1644,8 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args ---------------- HsValArg: a normal argument (fun ty) (HsValArg arg : args, Just (ki_binder, inner_ki)) -- next binder is invisible; need to instantiate it - | isInvisibleBinder ki_binder -- FunTy with InvisArg on LHS; - -- or ForAllTy with Inferred or Specified + | isInvisiblePiTyBinder ki_binder -- FunTy with constraint on LHS; + -- or ForAllTy with Inferred or Specified -> instantiate ki_binder inner_ki -- "normal" case @@ -1648,9 +1653,9 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args -> do { traceTc "tcInferTyApps (vis normal app)" (vcat [ ppr ki_binder , ppr arg - , ppr (tyBinderType ki_binder) + , ppr (piTyBinderType ki_binder) , ppr subst ]) - ; let exp_kind = substTy subst $ tyBinderType ki_binder + ; let exp_kind = substTy subst $ piTyBinderType ki_binder ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $ tc_lhs_type mode arg exp_kind ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind) @@ -1663,7 +1668,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args do { let arrows_needed = n_initial_val_args all_args ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki - ; fun' <- zonkTcType (fun `mkTcCastTy` co) + ; fun' <- zonkTcType (fun `mkCastTy` co) -- This zonk is essential, to expose the fruits -- of matchExpectedFunKind to the 'go' loop @@ -1671,7 +1676,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args vcat [ ppr fun <+> dcolon <+> ppr fun_ki , ppr arrows_needed , ppr co - , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] + , ppr fun' <+> dcolon <+> ppr (typeKind fun')] ; go_init n fun' all_args } -- Use go_init to establish go's INVARIANT where @@ -1704,14 +1709,14 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args = failWith $ TcRnInvalidVisibleKindArgument arg ty mkAppTyM :: Subst - -> TcType -> TyCoBinder -- fun, plus its top-level binder + -> TcType -> PiTyBinder -- fun, plus its top-level binder -> TcType -- arg -> TcM (Subst, TcType) -- Extended subst, plus (fun arg) -- Precondition: the application (fun arg) is well-kinded after zonking -- That is, the application makes sense -- -- Precondition: for (mkAppTyM subst fun bndr arg) --- tcTypeKind fun = Pi bndr. body +-- typeKind fun = Pi bndr. body -- That is, fun always has a ForAllTy or FunTy at the top -- and 'bndr' is fun's pi-binder -- @@ -1719,7 +1724,7 @@ mkAppTyM :: Subst -- invariant, then so does the result type (fun arg) -- -- We do not require that --- tcTypeKind arg = tyVarKind (binderVar bndr) +-- typeKind arg = tyVarKind (binderVar bndr) -- This must be true after zonking (precondition 1), but it's not -- required for the (PKTI). mkAppTyM subst fun ki_binder arg @@ -1754,7 +1759,7 @@ mk_app_ty fun arg (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $ mkAppTy fun arg where - fun_kind = tcTypeKind fun + fun_kind = typeKind fun isTrickyTvBinder :: TcTyVar -> Bool -- NB: isTrickyTvBinder is just an optimisation @@ -1765,14 +1770,14 @@ isTrickyTvBinder tv = isPiTy (tyVarKind tv) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During type inference, we maintain this invariant - (PKTI) It is legal to call 'tcTypeKind' on any Type ty, + (PKTI) It is legal to call 'typeKind' on any Type ty, on any sub-term of ty, /without/ zonking ty Moreover, any such returned kind will itself satisfy (PKTI) -By "legal to call tcTypeKind" we mean "tcTypeKind will not crash". -The way in which tcTypeKind can crash is in applications +By "legal to call typeKind" we mean "typeKind will not crash". +The way in which typeKind can crash is in applications (a t1 t2 .. tn) if 'a' is a type variable whose kind doesn't have enough arrows or foralls. (The crash is in piResultTys.) @@ -1785,7 +1790,7 @@ For example, suppose a :: kappa then consider the type (a Int) -If we call tcTypeKind on that, we'll crash, because the (un-zonked) +If we call typeKind on that, we'll crash, because the (un-zonked) kind of 'a' is just kappa, not an arrow kind. So we must zonk first. So the type inference engine is very careful when building applications. @@ -1844,7 +1849,7 @@ bound variable has a pi-type. Hence isTrickyTvBinder. saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) -- Precondition for (saturateFamApp ty kind): --- tcTypeKind ty = kind +-- typeKind ty = kind -- -- If 'ty' is an unsaturated family application with trailing -- invisible arguments, instantiate them. @@ -1852,10 +1857,10 @@ saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) saturateFamApp ty kind | Just (tc, args) <- tcSplitTyConApp_maybe ty - , mustBeSaturated tc + , tyConMustBeSaturated tc , let n_to_inst = tyConArity tc - length args = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind - ; return (ty `mkTcAppTys` extra_args, ki') } + ; return (ty `mkAppTys` extra_args, ki') } | otherwise = return (ty, kind) @@ -1923,7 +1928,7 @@ checkExpectedKind hs_ty ty act_kind exp_kind , text "act_kind':" <+> ppr act_kind' , text "exp_kind:" <+> ppr exp_kind ] - ; let res_ty = ty `mkTcAppTys` new_args + ; let res_ty = ty `mkAppTys` new_args ; if act_kind' `tcEqType` exp_kind then return res_ty -- This is very common @@ -1931,7 +1936,7 @@ checkExpectedKind hs_ty ty act_kind exp_kind ; traceTc "checkExpectedKind" (vcat [ ppr act_kind , ppr exp_kind , ppr co_k ]) - ; return (res_ty `mkTcCastTy` co_k) } } + ; return (res_ty `mkCastTy` co_k) } } where -- We need to make sure that both kinds have the same number of implicit -- foralls out front. If the actual kind has more, instantiate accordingly. @@ -2468,7 +2473,7 @@ kcInferDeclHeader name flav -- recursive group. -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - tc_binders = mkAnonTyConBinders VisArg tc_tvs + tc_binders = mkAnonTyConBinders tc_tvs -- Also, note that tc_binders has the tyvars from only the -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] -- in GHC.Tc.TyCl @@ -3032,7 +3037,7 @@ tcTKTelescope mode tele thing_inside = case tele of , sm_tvtv = SMDSkolemTv skol_info } ; (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside -- req_tv_bndrs :: [VarBndr TyVar ()], - -- but we want [VarBndr TyVar ArgFlag] + -- but we want [VarBndr TyVar ForAllTyFlag] ; return (tyVarReqToBinders req_tv_bndrs, thing) } HsForAllInvis { hsf_invis_bndrs = bndrs } @@ -3041,7 +3046,7 @@ tcTKTelescope mode tele thing_inside = case tele of , sm_tvtv = SMDSkolemTv skol_info } ; (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside -- inv_tv_bndrs :: [VarBndr TyVar Specificity], - -- but we want [VarBndr TyVar ArgFlag] + -- but we want [VarBndr TyVar ForAllTyFlag] ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } -------------------------------------- @@ -3709,7 +3714,7 @@ splitTyConKind skol_info in_scope avoid_occs kind = case splitPiTy_maybe kind of Nothing -> (reverse acc, substTy subst kind) - Just (Anon af arg, kind') + Just (Anon arg af, kind') -> go occs' uniqs' subst' (tcb : acc) kind' where tcb = Bndr tv (AnonTCB af) @@ -3730,8 +3735,8 @@ splitTyConKind skol_info in_scope avoid_occs kind ; return (go new_occs new_uniqs subst [] kind) } isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool -isAllowedDataResKind AnyTYPEKind kind = tcIsRuntimeTypeKind kind -isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind +isAllowedDataResKind AnyTYPEKind kind = isTypeLikeKind kind +isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind isAllowedDataResKind LiftedKind kind = tcIsLiftedTypeKind kind -- | Checks that the return kind in a data declaration's kind signature is @@ -3814,7 +3819,7 @@ checkDataKindSig data_sort kind -- In the particular case of a data family, permit a return kind of the -- form `:: k` (where `k` is a bare kind variable). is_kind_var :: Bool - is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind) + is_kind_var | is_data_family = isJust (getCastedTyVar_maybe res_kind) | otherwise = False err_msg :: DynFlags -> TcRnMessage @@ -3822,7 +3827,7 @@ checkDataKindSig data_sort kind TcRnInvalidReturnKind data_sort (allowed_kind dflags) kind (ext_hint dflags) ext_hint dflags - | tcIsRuntimeTypeKind kind + | isTypeLikeKind kind , is_newtype , not (xopt LangExt.UnliftedNewtypes dflags) = Just SuggestUnliftedNewtypes @@ -3836,7 +3841,7 @@ checkDataKindSig data_sort kind -- | Checks that the result kind of a class is exactly `Constraint`, rejecting -- type synonyms and type families that reduce to `Constraint`. See #16826. checkClassKindSig :: Kind -> TcM () -checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg +checkClassKindSig kind = checkTc (isConstraintKind kind) err_msg where err_msg :: TcRnMessage err_msg = TcRnClassKindNotConstraint kind @@ -3853,7 +3858,7 @@ tcbVisibilities tc orig_args go fun_kind subst all_args@(arg : args) | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind = case tcb of - Anon af _ -> AnonTCB af : go inner_kind subst args + Anon _ af -> AnonTCB af : go inner_kind subst args Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args where subst' = extendTCvSubst subst tv arg @@ -3959,7 +3964,9 @@ tcHsPartialSigType ctxt sig_ty (theta, wcx) <- tcPartialContext mode hs_ctxt ; ek <- newOpenTypeKind - ; tau <- addTypeCtxt hs_tau $ + ; tau <- -- Don't do (addTypeCtxt hs_tau) here else we get + -- In the type <blah> + -- In the type signature: foo :: <blah> tc_lhs_type mode hs_tau ek ; return (wcs, wcx, theta, tau) } @@ -3971,7 +3978,7 @@ tcHsPartialSigType ctxt sig_ty -- No kind-generalization here: ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $ - mkPhiTy theta $ + tcMkPhiTy theta $ tau) -- Spit out the wildcards (including the extra-constraints one) @@ -4139,9 +4146,6 @@ more. So I use a HACK: * Because it is ill-kinded (unifying something of kind Constraint with something of kind Type), it should trip an assert in writeMetaTyVarRef. - However, writeMetaTyVarRef uses eqType, not tcEqType, to avoid falling - over in this scenario (and another scenario, as detailed in - Note [coreView vs tcView] in GHC.Core.Type). Result works fine, but it may eventually bite us. diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 94f11dd5ea..7c331fb970 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -113,7 +113,7 @@ tcMatchesFun fun_id matches exp_ty ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> -- NB: exp_type may be polymorphic, but -- matchExpectedFunTys can cope with that - tcScalingUsage Many $ + tcScalingUsage ManyTy $ -- toplevel bindings and let bindings are, at the -- moment, always unrestricted. The value being bound -- must, accordingly, be unrestricted. Hence them @@ -178,7 +178,7 @@ tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -- Used for pattern bindings tcGRHSsPat grhss res_ty - = tcScalingUsage Many $ + = tcScalingUsage ManyTy $ -- Like in tcMatchesFun, this scaling happens because all -- let bindings are unrestricted. A difference, here, is -- that when this is not the case, any more, we will have to @@ -421,7 +421,7 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside tcGuardStmt :: TcExprStmtChecker tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside - = do { guard' <- tcScalingUsage Many $ tcCheckMonoExpr guard boolTy + = do { guard' <- tcScalingUsage ManyTy $ tcCheckMonoExpr guard boolTy -- Scale the guard to Many (see #19120 and #19193) ; thing <- thing_inside res_ty ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } @@ -434,7 +434,7 @@ tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside -- The multiplicity of x in u must be the same as the multiplicity at -- which the rhs has been consumed. When solving #18738, we want these -- two multiplicity to still be the same. - (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs + (rhs', rhs_ty) <- tcScalingUsage ManyTy $ tcInferRhoNC rhs -- Stmt has a context already ; hasFixedRuntimeRep_syntactic FRRBindStmtGuard rhs_ty ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) @@ -542,7 +542,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts -- typically something like [(Int,Bool,Int)] -- We don't know what tuple_ty is yet, so we use a variable ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id)) + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name ManyTy (n_app (idType bndr_id)) -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` @@ -735,7 +735,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap --------------- Building the bindersMap ---------------- ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id)) + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name ManyTy (n_app (idType bndr_id)) -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` @@ -916,7 +916,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names res_ty thing_inside = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith (\n t -> mkLocalId n Many t) tup_names tup_elt_tys + ; let tup_ids = zipWith (\n t -> mkLocalId n ManyTy t) tup_names tup_elt_tys -- Many because it's a recursive definition tup_ty = mkBigCoreTupTy tup_elt_tys diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index c82a6ac1b5..35c2463cb6 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -54,6 +54,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin import GHC.Core.TyCon import GHC.Core.Type +import GHC.Core.Coercion import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.ConLike @@ -232,7 +233,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl -- level, we'd be in checking mode (see tcConArg) -- hence this assertion do { bndr_ty <- inferResultToType infer_res - ; return (mkTcNomReflCo bndr_ty, bndr_ty) } + ; return (mkNomReflCo bndr_ty, bndr_ty) } ; let bndr_mult = scaledMult exp_pat_ty ; bndr_id <- newLetBndr no_gen bndr_name bndr_mult bndr_ty ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl @@ -353,7 +354,7 @@ tc_lpats tys penv pats -------------------- -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. checkManyPattern :: Scaled a -> TcM HsWrapper -checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin Many (scaledMult pat_ty) +checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin ManyTy (scaledMult pat_ty) tc_pat :: Scaled ExpSigmaTypeFRR -- ^ Fully refined result type @@ -392,7 +393,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- Check that the expected pattern type is itself lifted ; pat_ty <- readExpType (scaledThing pat_ty) - ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind + ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind ; return (mkHsWrapPat mult_wrap (LazyPat x pat') pat_ty, res) } @@ -1106,7 +1107,7 @@ matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (co, res) <- inner_match pat_rho ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) - ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) } + ; return (mkWpCastN (mkSymCo co) <.> wrap, res) } ---------------------------- matchExpectedConTy :: PatEnv @@ -1143,10 +1144,10 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty -- for actual vs. expected in error messages. ; let tys' = mkTyVarTys tvs' - co2 = mkTcUnbranchedAxInstCo co_tc tys' [] + co2 = mkUnbranchedAxInstCo Representational co_tc tys' [] -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 - full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2 + full_co = mkSubCo (mkSymCo co1) `mkTransCo` co2 -- full_co :: pat_rho ~R T7 ty1 ty2 ; return ( mkWpCastR full_co <.> wrap, tys') } @@ -1155,7 +1156,7 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho - ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } + ; return (mkWpCastN (mkSymCo coi) <.> wrap, tys) } {- Note [Matching constructor patterns] @@ -1247,7 +1248,7 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of (arityErr (text "constructor") con_like con_arity no_of_args) -- forgetting to filter out inferred binders led to #20443 - ; let con_spec_binders = filter ((== SpecifiedSpec) . binderArgFlag) $ + ; let con_spec_binders = filter ((== SpecifiedSpec) . binderFlag) $ conLikeUserTyVarBinders con_like ; checkTc (type_args `leLength` con_spec_binders) (TcRnTooManyTyArgsInConPattern con_like (length con_spec_binders) (length type_args)) diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index 38572d7341..047c0559bf 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -17,7 +17,6 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Solver import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Types.Constraint -import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -25,9 +24,12 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Expr import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify( buildImplicationFor ) -import GHC.Tc.Types.Evidence( mkTcCoVarCo ) + import GHC.Core.Type +import GHC.Core.Coercion( mkCoVarCo ) import GHC.Core.TyCon( isTypeFamilyTyCon ) +import GHC.Core.Predicate + import GHC.Types.Id import GHC.Types.Var( EvVar, tyVarName ) import GHC.Types.Var.Set @@ -229,7 +231,7 @@ tcRuleTmBndrs _ [] = return ([],[]) tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs) = do { ty <- newOpenFlexiTyVarTy ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs - ; return (tyvars, mkLocalId name Many ty : tmvars) } + ; return (tyvars, mkLocalId name ManyTy ty : tmvars) } tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) -- e.g x :: a->a -- The tyvar 'a' is brought into scope first, just as if you'd written @@ -238,7 +240,7 @@ tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) -- error for each out-of-scope type variable used = do { let ctxt = RuleSigCtxt rule_name name ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind - ; let id = mkLocalId name Many id_ty + ; let id = mkLocalId name ManyTy id_ty -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType -- The type variables scope over subsequent bindings; yuk @@ -444,7 +446,7 @@ simplifyRule name tc_lvl lhs_wanted rhs_wanted EvVarDest ev_id -> return ev_id HoleDest hole -> -- See Note [Quantifying over coercion holes] do { ev_id <- newEvVar pred - ; fillCoercionHole hole (mkTcCoVarCo ev_id) + ; fillCoercionHole hole (mkCoVarCo ev_id) ; return ev_id } mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct) diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 6b141d9173..b1e59a78b3 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -230,7 +230,7 @@ tcUserTypeSig loc hs_sig_ty mb_name = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty ; traceTc "tcuser" (ppr sigma_ty) ; return $ - CompleteSig { sig_bndr = mkLocalId name Many sigma_ty + CompleteSig { sig_bndr = mkLocalId name ManyTy sigma_ty -- We use `Many' as the multiplicity here, -- as if this identifier corresponds to -- anything, it is a top-level @@ -317,7 +317,7 @@ no_anon_wc_ty lty = go lty && go ty HsQualTy { hst_ctxt = ctxt , hst_body = ty } -> gos (unLoc ctxt) && go ty - HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go $ L noSrcSpanA ty + HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go ty HsSpliceTy (HsUntypedSpliceNested _) _ -> True HsTyLit{} -> True HsTyVar{} -> True diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 91c9b68736..6ef55ddf4c 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -676,7 +676,7 @@ tcTypedBracket rn_expr expr res_ty -- (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr) -- We'll typecheck it again when we splice it in somewhere ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $ - tcScalingUsage Many $ + tcScalingUsage ManyTy $ -- Scale by Many, TH lifting is currently nonlinear (#18465) tcInferRhoNC expr -- NC for no context; tcBracket does that @@ -779,7 +779,7 @@ tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) = do { meta_ty <- tcMetaTy meta_ty_name -- Expected type of splice, e.g. m Exp ; let expected_type = mkAppTy m_var meta_ty - ; expr' <- tcScalingUsage Many $ tcCheckPolyExpr expr expected_type + ; expr' <- tcScalingUsage ManyTy $ tcCheckPolyExpr expr expected_type -- Scale by Many, TH lifting is currently nonlinear (#18465) ; return (PendingTcSplice splice_name expr') } where @@ -1903,7 +1903,7 @@ reifyInstances' th_nm th_tys -- In particular, the type might have kind -- variables inside it (#7477) - ; traceTc "reifyInstances'" (ppr ty $$ ppr (tcTypeKind ty)) + ; traceTc "reifyInstances'" (ppr ty $$ ppr (typeKind ty)) ; case splitTyConApp_maybe ty of -- This expands any type synonyms Just (tc, tys) -- See #7910 | Just cls <- tyConClass_maybe tc @@ -2109,8 +2109,10 @@ reifyTyCon tc | Just cls <- tyConClass_maybe tc = reifyClass cls - | isFunTyCon tc - = return (TH.PrimTyConI (reifyName tc) 2 False) +{- Seems to be just a short cut for the next equation -- omit + | tc `hasKey` fUNTyConKey -- I'm not quite sure what is happening here + = return (TH.PrimTyConI (reifyName tc) 2 False) +-} | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) @@ -2254,7 +2256,7 @@ reifyDataCon isGadtDataCon tys dc subst_tv_binders subst tv_bndrs = let tvs = binderVars tv_bndrs - flags = map binderArgFlag tv_bndrs + flags = binderFlags tv_bndrs (subst', tvs') = substTyVarBndrs subst tvs tv_bndrs' = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags) in (subst', tv_bndrs') @@ -2348,7 +2350,7 @@ annotThType :: Bool -- True <=> annotate annotThType _ _ th_ty@(TH.SigT {}) = return th_ty annotThType True ty th_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty - = do { let ki = tcTypeKind ty + = do { let ki = typeKind ty ; th_ki <- reifyKind ki ; return (TH.SigT th_ty th_ki) } annotThType _ _ th_ty = return th_ty @@ -2362,7 +2364,7 @@ tyConArgsPolyKinded tc = map (is_poly_ty . tyVarKind) tc_vis_tvs -- See "Wrinkle: Oversaturated data family instances" in -- @Note [Reified instances and explicit kind signatures]@ - ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle + ++ map (is_poly_ty . piTyBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle ++ repeat True -- (2) in Wrinkle where is_poly_ty :: Type -> Bool @@ -2374,8 +2376,8 @@ tyConArgsPolyKinded tc = tc_vis_tvs :: [TyVar] tc_vis_tvs = tyConVisibleTyVars tc - tc_res_kind_vis_bndrs :: [TyCoBinder] - tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc + tc_res_kind_vis_bndrs :: [PiTyBinder] + tc_res_kind_vis_bndrs = filter isVisiblePiTyBinder $ fst $ splitPiTys $ tyConResKind tc {- Note [Reified instances and explicit kind signatures] @@ -2530,7 +2532,7 @@ reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor -- Note [Reified instances and explicit kind signatures] if (null cons || isGadtSyntaxTyCon rep_tc) && tyConAppNeedsKindSig False fam_tc (length ee_lhs) - then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs) + then do { let full_kind = typeKind (mkTyConApp fam_tc ee_lhs) ; th_full_kind <- reifyKind full_kind ; pure $ Just th_full_kind } else pure Nothing @@ -2566,23 +2568,23 @@ reifyType ty@(AppTy {}) = do -- `Type` argument is invisible (#15792). filter_out_invisible_args :: Type -> [Type] -> [Type] filter_out_invisible_args ty_head ty_args = - filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) + filterByList (map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args) ty_args -reifyType ty@(FunTy { ft_af = af, ft_mult = Many, ft_arg = t1, ft_res = t2 }) - | InvisArg <- af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) - | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] - ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } +reifyType ty@(FunTy { ft_af = af, ft_mult = ManyTy, ft_arg = t1, ft_res = t2 }) + | isInvisibleFunArg af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) + | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] + ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 }) - | InvisArg <- af = noTH LinearInvisibleArgument ty - | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] - ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } + | isInvisibleFunArg af = noTH LinearInvisibleArgument ty + | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] + ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH reifyType ty@(CoercionTy {})= noTH CoercionsInTypes ty -reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type +reify_for_all :: TyCoRep.ForAllTyFlag -> TyCoRep.Type -> TcM TH.Type -- Arg of reify_for_all is always ForAllTy or a predicate FunTy reify_for_all argf ty - | isVisibleArgFlag argf + | isVisibleForAllTyFlag argf = do let (req_bndrs, phi) = tcSplitForAllReqTVBinders ty tvbndrs' <- reifyTyVarBndrs req_bndrs phi' <- reifyType phi @@ -2613,7 +2615,7 @@ reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) ; req' <- reifyCxt req ; exTyVars' <- reifyTyVarBndrs exTyVars ; prov' <- reifyCxt prov - ; tau' <- reifyType (mkVisFunTys argTys resTy) + ; tau' <- reifyType (mkScaledFunTys argTys resTy) ; return $ TH.ForallT univTyVars' req' $ TH.ForallT exTyVars' prov' tau' } @@ -2690,7 +2692,7 @@ reify_tc_app tc tys -- don't count specified binders as contributing towards -- injective positions in the kind of the tycon. tc (length tys) - = do { let full_kind = tcTypeKind (mkTyConApp tc tys) + = do { let full_kind = typeKind (mkTyConApp tc tys) ; th_full_kind <- reifyKind full_kind ; return (TH.SigT th_type th_full_kind) } | otherwise diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index 0d96d4420e..57ee52144c 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -38,6 +38,7 @@ import GHC.Types.Id.Make ( nospecId ) import GHC.Types.Var import GHC.Core.Predicate +import GHC.Core.Coercion import GHC.Core.InstEnv import GHC.Core.Type import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) @@ -54,8 +55,6 @@ import GHC.Data.FastString import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Data.Maybe - {- ******************************************************************* * * A helper for associated types within @@ -154,20 +153,17 @@ matchGlobalInst :: DynFlags -- See Note [Shortcut solving: overlap] -> Class -> [Type] -> TcM ClsInstResult matchGlobalInst dflags short_cut clas tys - | cls_name == knownNatClassName - = matchKnownNat dflags short_cut clas tys - | cls_name == knownSymbolClassName - = matchKnownSymbol dflags short_cut clas tys - | cls_name == knownCharClassName - = matchKnownChar dflags short_cut clas tys - | isCTupleClass clas = matchCTuple clas tys - | cls_name == typeableClassName = matchTypeable clas tys - | cls_name == withDictClassName = matchWithDict tys - | clas `hasKey` heqTyConKey = matchHeteroEquality tys - | clas `hasKey` eqTyConKey = matchHomoEquality tys - | clas `hasKey` coercibleTyConKey = matchCoercible tys - | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys - | otherwise = matchInstEnv dflags short_cut clas tys + | cls_name == knownNatClassName = matchKnownNat dflags short_cut clas tys + | cls_name == knownSymbolClassName = matchKnownSymbol dflags short_cut clas tys + | cls_name == knownCharClassName = matchKnownChar dflags short_cut clas tys + | isCTupleClass clas = matchCTuple clas tys + | cls_name == typeableClassName = matchTypeable clas tys + | cls_name == withDictClassName = matchWithDict tys + | clas `hasKey` heqTyConKey = matchHeteroEquality tys + | clas `hasKey` eqTyConKey = matchHomoEquality tys + | clas `hasKey` coercibleTyConKey = matchCoercible tys + | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys + | otherwise = matchInstEnv dflags short_cut clas tys where cls_name = className clas @@ -193,7 +189,7 @@ matchInstEnv dflags short_cut_solver clas tys -- Nothing matches ([], NoUnifiers, _) - -> do { traceTc "matchClass not matching" (ppr pred) + -> do { traceTc "matchClass not matching" (ppr pred $$ ppr (ie_local instEnvs)) ; return NoInstance } -- A single match (& no safe haskell failure) @@ -427,7 +423,7 @@ makeLitDict clas ty et -- then tcRep is SNat , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] -- SNat n ~ Integer - , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep)) + , let ev_tm = mkEvCast et (mkSymCo (mkTransCo co_dict co_rep)) = return $ OneInst { cir_new_theta = [] , cir_mk_ev = \_ -> ev_tm , cir_what = BuiltinInstance } @@ -454,8 +450,8 @@ matchWithDict [cls, mty] -- and in that case let -- co :: C t1 ..tn ~R# inst_meth_ty , Just (inst_meth_ty, co) <- tcInstNewTyCon_maybe dict_tc dict_args - = do { sv <- mkSysLocalM (fsLit "withDict_s") Many mty - ; k <- mkSysLocalM (fsLit "withDict_k") Many (mkInvisFunTyMany cls openAlphaTy) + = do { sv <- mkSysLocalM (fsLit "withDict_s") ManyTy mty + ; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls openAlphaTy) -- Given co2 : mty ~N# inst_meth_ty, construct the method of -- the WithDict dictionary: @@ -472,11 +468,11 @@ matchWithDict [cls, mty] mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ Var nospecId `App` - (Type $ mkInvisFunTyMany cls openAlphaTy) + (Type $ mkInvisFunTy cls openAlphaTy) `App` Var k `App` - (Var sv `Cast` mkTcTransCo (mkTcSubCo co2) (mkTcSymCo co)) + (Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co)) ; tc <- tcLookupTyCon withDictClassName ; let Just withdict_data_con @@ -646,18 +642,29 @@ Some further observations about `withDict`: -- and it was applied to the correct argument. matchTypeable :: Class -> [Type] -> TcM ClsInstResult matchTypeable clas [k,t] -- clas = Typeable - -- For the first two cases, See Note [No Typeable for polytypes or qualified types] - | isForAllTy k = return NoInstance -- Polytype - | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type + -- Forall types: see Note [No Typeable for polytypes or qualified types] + | isForAllTy k = return NoInstance + + -- Functions; but only with a visible argment + | Just (af,mult,arg,ret) <- splitFunTy_maybe t + = if isVisibleFunArg af + then doFunTy clas t mult arg ret + else return NoInstance + -- 'else' case: qualified types like (Num a => blah) are not typeable + -- see Note [No Typeable for polytypes or qualified types] -- Now cases that do work - | k `eqType` naturalTy = doTyLit knownNatClassName t - | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t - | k `eqType` charTy = doTyLit knownCharClassName t - | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] - | Just (mult,arg,ret) <- splitFunTy_maybe t = doFunTy clas t mult arg ret + | k `eqType` naturalTy = doTyLit knownNatClassName t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t + | k `eqType` charTy = doTyLit knownCharClassName t + + -- TyCon applied to its kind args + -- No special treatment of Type and Constraint; they get distinct TypeReps + -- see wrinkle (W4) of Note [Type and Constraint are not apart] + -- in GHC.Builtin.Types.Prim. | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks + | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt matchTypeable _ _ = return NoInstance @@ -681,10 +688,9 @@ doFunTy clas ty mult arg_ty ret_ty doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult doTyConApp clas ty tc kind_args | tyConIsTypeable tc - = do - return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args) - , cir_mk_ev = mk_ev - , cir_what = BuiltinTypeableInstance tc } + = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) kind_args + , cir_mk_ev = mk_ev + , cir_what = BuiltinTypeableInstance tc } | otherwise = return NoInstance where @@ -710,7 +716,7 @@ doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult -- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) -- Typeable f doTyApp clas ty f tk - | isForAllTy (tcTypeKind f) + | isForAllTy (typeKind f) = return NoInstance -- We can't solve until we know the ctr. | otherwise = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk] @@ -723,7 +729,7 @@ doTyApp clas ty f tk -- Emit a `Typeable` constraint for the given type. mk_typeable_pred :: Class -> Type -> PredType -mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ] +mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ] -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal -- we generate a sub-goal for the appropriate class. @@ -739,14 +745,31 @@ doTyLit kc t = do { kc_clas <- tcLookupClass kc {- Note [Typeable (T a b c)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + For type applications we always decompose using binary application, -via doTyApp, until we get to a *kind* instantiation. Example - Proxy :: forall k. k -> * +via doTyApp (building a TrApp), until we get to a *kind* instantiation +(building a TrTyCon). We detect a pure kind instantiation using +`onlyNamedBndrsApplied`. + +Example: Proxy :: forall k. k -> * + + To solve Typeable (Proxy @(* -> *) Maybe) we + + - First decompose with doTyApp (onlyNamedBndrsApplied is False) + to get (Typeable (Proxy @(* -> *))) and Typeable Maybe. + This step returns a TrApp. + + - Then solve (Typeable (Proxy @(* -> *))) with doTyConApp + (onlyNamedBndrsApplied is True). + This step returns a TrTyCon + + So the TypeRep we build is + TrApp (TrTyCon ("Proxy" @(*->*))) (TrTyCon "Maybe") -To solve Typeable (Proxy (* -> *) Maybe) we - - First decompose with doTyApp, - to get (Typeable (Proxy (* -> *))) and Typeable Maybe - - Then solve (Typeable (Proxy (* -> *))) with doTyConApp +Notice also that TYPE and CONSTRAINT are distinct so, in effect, we +allow (Typeable TYPE) and (Typeable CONSTRAINT), giving disinct TypeReps. +This is very important: we may want to get a TypeRep for a kind like + Type -> Constraint If we attempt to short-cut by solving it all at once, via doTyConApp @@ -939,8 +962,8 @@ matchHasField dflags short_cut clas tys -- it to a HasField dictionary. mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co where - co = mkTcSubCo (evTermCoercion (EvExpr ev1)) - `mkTcTransCo` mkTcSymCo co2 + co = mkSubCo (evTermCoercion (EvExpr ev1)) + `mkTransCo` mkSymCo co2 mk_ev [] = panic "matchHasField.mk_ev" Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs index 710750a57d..681fd5d9a2 100644 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -29,14 +29,18 @@ import GHC.Types.Var import GHC.Core.Class import GHC.Core.Predicate import GHC.Core.Type -import GHC.Tc.Utils.TcType( transSuperClasses ) +import GHC.Core.RoughMap( RoughMatchTc(..) ) import GHC.Core.Coercion.Axiom( TypeEqn ) import GHC.Core.Unify import GHC.Core.InstEnv -import GHC.Types.Var.Set -import GHC.Types.Var.Env import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Compare( eqTypes, eqType ) import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) + +import GHC.Tc.Utils.TcType( transSuperClasses ) + +import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Types.SrcLoc import GHC.Utils.Outputable @@ -122,11 +126,12 @@ Wrinkles: [W] D Int Bool ty Then we'll generate - FDEqn { fd_qtvs = [x], fd_eqs = [Pair x Bool, Pair (Maybe x) ty] } + FDEqn { fd_qtvs = [x0], fd_eqs = [ x0 ~ Bool, Maybe x0 ~ ty] } + which generates one fresh unification variable x0 But if the fundeps had been (a->b, a->c) we'd generate two FDEqns - FDEqn { fd_qtvs = [x], fd_eqs = [Pair x Bool] } - FDEqn { fd_qtvs = [x], fd_eqs = [Pair (Maybe x) ty] } + FDEqn { fd_qtvs = [x1], fd_eqs = [ x1 ~ Bool ] } + FDEqn { fd_qtvs = [x2], fd_eqs = [ Maybe x2 ~ ty ] } with two FDEqns, generating two separate unification variables. (3) improveFromInstEnv doesn't return any equations that already hold. @@ -405,7 +410,7 @@ checkInstCoverage be_liberal clas theta inst_taus where (ls,rs) = instFD fd tyvars inst_taus ls_tvs = tyCoVarsOfTypes ls - rs_tvs = splitVisVarsOfTypes rs + rs_tvs = visVarsOfTypes rs undetermined_tvs | be_liberal = liberal_undet_tvs | otherwise = conserv_undet_tvs diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index d5ad9b5186..9de6aa9e94 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -13,7 +13,7 @@ module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where import GHC.Prelude import GHC.Platform -import GHC.Types.Basic ( Boxity(..), neverInlinePragma ) +import GHC.Types.Basic ( Boxity(..), TypeOrConstraint(..), neverInlinePragma ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) @@ -330,9 +330,11 @@ mkPrimTypeableTodos -- Build TypeRepTodos for built-in KindReps ; todo1 <- todoForExportedKindReps builtInKindReps + -- Build TypeRepTodos for types in GHC.Prim ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id ghcPrimTypeableTyCons + ; return ( gbl_env' , [todo1, todo2]) } else do gbl_env <- getGblEnv @@ -406,7 +408,7 @@ mkTyConRepBinds :: TypeableStuff -> TypeRepTodo -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) mkTyConRepBinds stuff todo (TypeableTyCon {..}) = do -- Make a KindRep - let (bndrs, kind) = splitForAllTyCoVarBinders (tyConKind tycon) + let (bndrs, kind) = splitForAllForAllTyBinders (tyConKind tycon) liftTc $ traceTc "mkTyConKindRepBinds" (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) let ctx = mkDeBruijnContext (map binderVar bndrs) @@ -420,9 +422,8 @@ mkTyConRepBinds stuff todo (TypeableTyCon {..}) -- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type -- families and polytypes. tyConIsTypeable :: TyCon -> Bool -tyConIsTypeable tc = - isJust (tyConRepName_maybe tc) - && kindIsTypeable (dropForAlls $ tyConKind tc) +tyConIsTypeable tc = isJust (tyConRepName_maybe tc) + && kindIsTypeable (dropForAlls $ tyConKind tc) -- | Is a particular 'Kind' representable by @Typeable@? Here we look for -- polytypes and types containing casts (which may be, for instance, a type @@ -464,12 +465,14 @@ newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a } liftTc :: TcRn a -> KindRepM a liftTc = KindRepM . lift --- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they +-- | We generate `KindRep`s for a few common kinds, so that they -- can be reused across modules. +-- These definitions are generated in `ghc-prim:GHC.Types`. builtInKindReps :: [(Kind, Name)] builtInKindReps = - [ (star, starKindRepName) - , (mkVisFunTyMany star star, starArrStarKindRepName) + [ (star, starKindRepName) + , (constraintKind, constraintKindRepName) + , (mkVisFunTyMany star star, starArrStarKindRepName) , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName) ] where @@ -481,6 +484,7 @@ initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps add_kind_rep acc (k,n) = do id <- tcLookupId n return $! extendTypeMap acc k (id, Nothing) + -- The TypeMap looks through type synonyms -- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's. mkExportedKindReps :: TypeableStuff @@ -496,6 +500,7 @@ mkExportedKindReps stuff = mapM_ kindrep_binding -- since the latter would find the built-in 'KindRep's in the -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv'). rhs <- mkKindRepRhs stuff empty_scope kind + liftTc (traceTc "mkExport" (ppr kind $$ ppr rep_bndr $$ ppr rhs)) addKindRepBind empty_scope kind rep_bndr rhs addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM () @@ -528,10 +533,8 @@ getKindRep stuff@(Stuff {..}) in_scope = go go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv) go' k env - -- Look through type synonyms - | Just k' <- tcView k = go' k' env - -- We've already generated the needed KindRep + -- This lookup looks through synonyms | Just (id, _) <- lookupTypeMapWithScope env in_scope k = return (nlHsVar id, env) @@ -540,7 +543,7 @@ getKindRep stuff@(Stuff {..}) in_scope = go = do -- Place a NOINLINE pragma on KindReps since they tend to be quite -- large and bloat interface files. rep_bndr <- (`setInlinePragma` neverInlinePragma) - <$> newSysLocalId (fsLit "$krep") Many (mkTyConTy kindRepTyCon) + <$> newSysLocalId (fsLit "$krep") ManyTy (mkTyConTy kindRepTyCon) -- do we need to tie a knot here? flip runStateT env $ unKindRepM $ do @@ -560,24 +563,27 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep_shortcut -- We handle (TYPE LiftedRep) etc separately to make it -- clear to consumers (e.g. serializers) that there is -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep) - | not (tcIsConstraintKind k) + | Just (TypeLike, rep) <- sORTKind_maybe k -- Typeable respects the Constraint/Type distinction -- so do not follow the special case here - , Just arg <- kindRep_maybe k - = case splitTyConApp_maybe arg of - Just (tc, []) + = -- Here k = TYPE <something> + case splitTyConApp_maybe rep of + Just (tc, []) -- TYPE IntRep, TYPE FloatRep etc | Just dc <- isPromotedDataCon_maybe tc -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc - Just (rep, [levArg]) - | Just dcRep <- isPromotedDataCon_maybe rep - , Just (lev, []) <- splitTyConApp_maybe levArg - , Just dcLev <- isPromotedDataCon_maybe lev + Just (rep_tc, [levArg]) -- TYPE (BoxedRep lev) + | Just dcRep <- isPromotedDataCon_maybe rep_tc + , Just (lev_tc, []) <- splitTyConApp_maybe levArg + , Just dcLev <- isPromotedDataCon_maybe lev_tc -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` (nlHsDataCon dcRep `nlHsApp` nlHsDataCon dcLev) _ -> new_kind_rep k | otherwise = new_kind_rep k + new_kind_rep ki -- Expand synonyms + | Just ki' <- coreView ki + = new_kind_rep ki' new_kind_rep (TyVarTy v) | Just idx <- lookupCME in_scope v diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 68728cd3d7..beb4c64557 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -121,7 +121,8 @@ import GHC.Core.Type import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.Reduction ( Reduction(..) ) -import GHC.Core.Unify( RoughMatchTc(..) ) +import GHC.Core.RoughMap( RoughMatchTc(..) ) +import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons , famInstEnvElts, extendFamInstEnvList, normaliseType ) @@ -1252,7 +1253,7 @@ checkBootTyCon is_boot tc1 tc2 -- data T a = MkT -- -- If you write this, we'll treat T as injective, and make inferences - -- like T a ~R T b ==> a ~N b (mkNthCo). But if we can + -- like T a ~R T b ==> a ~N b (mkSelCo). But if we can -- subsequently replace T with one at phantom role, we would then be able to -- infer things like T Int ~R T Bool which is bad news. -- @@ -2717,7 +2718,8 @@ tcRnType hsc_env flexi normalise rdr_type normaliseType fam_envs Nominal ty | otherwise = ty - ; return (ty', mkInfForAllTys kvs (tcTypeKind ty')) } + ; traceTc "tcRnExpr" (debugPprType ty $$ debugPprType ty') + ; return (ty', mkInfForAllTys kvs (typeKind ty')) } {- Note [TcRnExprMode] diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 6811d35ed0..cdc15959f8 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -58,7 +58,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Ppr import GHC.Core.TyCon ( TyConBinder, isTypeFamilyTyCon ) -import GHC.Builtin.Types ( liftedRepTy, manyDataConTy, liftedDataConTy ) +import GHC.Builtin.Types ( liftedRepTy, liftedDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -2895,7 +2895,7 @@ defaultTyVarTcS the_tv ; return True } | isMultiplicityVar the_tv = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv) - ; unifyTyVar the_tv manyDataConTy + ; unifyTyVar the_tv ManyTy ; return True } | otherwise = return False -- the common case @@ -2996,7 +2996,7 @@ to ensure that instance declarations match. For example consider foo x = show (\_ -> True) Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), -and that won't match the tcTypeKind (*) in the instance decl. See tests +and that won't match the typeKind (*) in the instance decl. See tests tc217 and tc175. We look only at touchable type variables. No further constraints @@ -3153,7 +3153,7 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys -- Ignore invisible arguments for this purpose - , Just tv <- tcGetTyVar_maybe ty + , Just tv <- getTyVar_maybe ty , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and -- we definitely don't want to try to assign to those! = Left (cc, cls, tv) diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index b3affa011d..10e992467e 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -52,6 +52,7 @@ import GHC.Data.Pair import GHC.Utils.Misc import GHC.Data.Bag import GHC.Utils.Monad +import GHC.Utils.Constants( debugIsOn ) import Control.Monad import Data.Maybe ( isJust, isNothing ) import Data.List ( zip4 ) @@ -942,23 +943,30 @@ unknown kind. For instance, we may have, FunTy (a :: k) Int -Where k is a unification variable. So the calls to getRuntimeRep_maybe may +Where k is a unification variable. So the calls to splitRuntimeRep_maybe may fail (returning Nothing). In that case we'll fall through, zonk, and try again. Zonking should fill the variable k, meaning that decomposition will succeed the second time around. -Also note that we require the AnonArgFlag to match. This will stop +Also note that we require the FunTyFlag to match. This will stop us decomposing (Int -> Bool) ~ (Show a => blah) -It's as if we treat (->) and (=>) as different type constructors. +It's as if we treat (->) and (=>) as different type constructors, which +indeed they are! -} canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) canEqNC ev eq_rel ty1 ty2 = do { result <- zonk_eq_types ty1 ty2 ; case result of - Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2 - Right ty -> canEqReflexive ev eq_rel ty } + Right ty -> canEqReflexive ev eq_rel ty + Left (Pair ty1' ty2') -> can_eq_nc False ev' eq_rel ty1' ty1' ty2' ty2' + where + ev' | debugIsOn = setCtEvPredType ev $ + mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2' + | otherwise = ev + -- ev': satisfy the precondition of can_eq_nc + } can_eq_nc :: Bool -- True => both types are rewritten @@ -967,6 +975,11 @@ can_eq_nc -> Type -> Type -- LHS, after and before type-synonym expansion, resp -> Type -> Type -- RHS, after and before type-synonym expansion, resp -> TcS (StopOrContinue Ct) +-- Precondition: in DEBUG mode, the `ctev_pred` of `ev` is (ps_ty1 ~# ps_ty2), +-- without zonking +-- This precondition is needed (only in DEBUG) to satisfy the assertions +-- in mkSelCo, called in canDecomposableTyConAppOK and canDecomposableFunTy + can_eq_nc rewritten ev eq_rel ty1 ps_ty1 ty2 ps_ty2 = do { traceTcS "can_eq_nc" $ vcat [ ppr rewritten, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] @@ -991,8 +1004,8 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConAp -- Expand synonyms first; see Note [Type synonyms and canonicalization] can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | Just ty1' <- tcView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 - | Just ty2' <- tcView ty2 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 + | Just ty1' <- coreView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 + | Just ty2' <- coreView ty2 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 -- need to check for reflexivity in the ReprEq case. -- See Note [Eager reflexivity check] @@ -1037,14 +1050,8 @@ can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ can_eq_nc' _rewritten _rdr_env _envs ev eq_rel (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1 (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2 - | af1 == af2 -- Don't decompose (Int -> blah) ~ (Show a => blah) - , Just ty1a_rep <- getRuntimeRep_maybe ty1a -- getRutimeRep_maybe: - , Just ty1b_rep <- getRuntimeRep_maybe ty1b -- see Note [Decomposing FunTy] - , Just ty2a_rep <- getRuntimeRep_maybe ty2a - , Just ty2b_rep <- getRuntimeRep_maybe ty2b - = canDecomposableTyConAppOK ev eq_rel funTyCon - [am1, ty1a_rep, ty1b_rep, ty1a, ty1b] - [am2, ty2a_rep, ty2b_rep, ty2a, ty2b] + | af1 == af2 -- See Note [Decomposing FunTy] + = canDecomposableFunTy ev eq_rel af1 (am1,ty1a,ty1b) (am2,ty2a,ty2b) -- Decompose type constructor applications -- NB: we have expanded type synonyms already @@ -1061,7 +1068,7 @@ can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _ can_eq_nc' _rewritten _rdr_env _envs ev eq_rel s1@(ForAllTy (Bndr _ vis1) _) _ s2@(ForAllTy (Bndr _ vis2) _) _ - | vis1 `sameVis` vis2 -- Note [ForAllTy and typechecker equality] + | vis1 `eqForAllVis` vis2 -- Note [ForAllTy and type equality] = can_eq_nc_forall ev eq_rel s1 s2 -- See Note [Canonicalising type applications] about why we require rewritten types @@ -1126,63 +1133,6 @@ If we have an unsolved equality like that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. So we want to make it a potentially-soluble Irred not an insoluble one. Missing this point is what caused #15431 - -Note [ForAllTy and typechecker equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should GHC type-check the following program (adapted from #15740)? - - {-# LANGUAGE PolyKinds, ... #-} - data D a - type family F :: forall k. k -> Type - type instance F = D - -Due to the way F is declared, any instance of F must have a right-hand side -whose kind is equal to `forall k. k -> Type`. The kind of D is -`forall {k}. k -> Type`, which is very close, but technically uses distinct -Core: - - ----------------------------------------------------------- - | Source Haskell | Core | - ----------------------------------------------------------- - | forall k. <...> | ForAllTy (Bndr k Specified) (<...>) | - | forall {k}. <...> | ForAllTy (Bndr k Inferred) (<...>) | - ----------------------------------------------------------- - -We could deem these kinds to be unequal, but that would imply rejecting -programs like the one above. Whether a kind variable binder ends up being -specified or inferred can be somewhat subtle, however, especially for kinds -that aren't explicitly written out in the source code (like in D above). -For now, we decide to not make the specified/inferred status of an invisible -type variable binder affect GHC's notion of typechecker equality -(see Note [Typechecker equality vs definitional equality] in -GHC.Tc.Utils.TcType). That is, we have the following: - - -------------------------------------------------- - | Type 1 | Type 2 | Equal? | - --------------------|----------------------------- - | forall k. <...> | forall k. <...> | Yes | - | | forall {k}. <...> | Yes | - | | forall k -> <...> | No | - -------------------------------------------------- - | forall {k}. <...> | forall k. <...> | Yes | - | | forall {k}. <...> | Yes | - | | forall k -> <...> | No | - -------------------------------------------------- - | forall k -> <...> | forall k. <...> | No | - | | forall {k}. <...> | No | - | | forall k -> <...> | Yes | - -------------------------------------------------- - -We implement this nuance by using the GHC.Types.Var.sameVis function in -GHC.Tc.Solver.Canonical.canEqNC and GHC.Tc.Utils.TcType.tcEqType, which -respect typechecker equality. sameVis puts both forms of invisible type -variable binders into the same equivalence class. - -Note that we do /not/ use sameVis in GHC.Core.Type.eqType, which implements -/definitional/ equality, a slightly more coarse-grained notion of equality -(see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep) that does -not consider the ArgFlag of ForAllTys at all. That is, eqType would equate all -of forall k. <...>, forall {k}. <...>, and forall k -> <...>. -} --------------------------------- @@ -1205,8 +1155,8 @@ can_eq_nc_forall ev eq_rel s1 s2 ; if not (equalLength bndrs1 bndrs2) then do { traceTcS "Forall failure" $ vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 - , ppr (map binderArgFlag bndrs1) - , ppr (map binderArgFlag bndrs2) ] + , ppr (binderFlags bndrs1) + , ppr (binderFlags bndrs2) ] ; canEqHardFailure ev s1 s2 } else do { traceTcS "Creating implication for polytype equality" $ ppr ev @@ -1229,7 +1179,7 @@ can_eq_nc_forall ev eq_rel s1 s2 -- skol_tv is already in the in-scope set, but the -- free vars of kind_co are not; hence "...AndInScope" ; (co, wanteds2) <- go skol_tvs subst' bndrs2 - ; return ( mkTcForAllCo skol_tv kind_co co + ; return ( mkForAllCo skol_tv kind_co co , wanteds1 `unionBags` wanteds2 ) } -- Done: unify phi1 ~ phi2 @@ -1259,7 +1209,7 @@ can_eq_nc_forall ev eq_rel s1 s2 -- than putting it in the work list unify loc rewriters role ty1 ty2 | ty1 `tcEqType` ty2 - = return (mkTcReflCo role ty1, emptyBag) + = return (mkReflCo role ty1, emptyBag) | otherwise = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2 ; return (co, unitBag (mkNonCanonical wanted)) } @@ -1295,23 +1245,19 @@ zonk_eq_types = go -- so we may run into an unzonked type variable while trying to compute the -- RuntimeReps of the argument and result types. This can be observed in -- testcase tc269. - go ty1 ty2 - | Just (Scaled w1 arg1, res1) <- split1 - , Just (Scaled w2 arg2, res2) <- split2 + go (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2) + | af1 == af2 , eqType w1 w2 = do { res_a <- go arg1 arg2 ; res_b <- go res1 res2 - ; return $ combine_rev (mkVisFunTy w1) res_b res_a - } - | isJust split1 || isJust split2 - = bale_out ty1 ty2 - where - split1 = tcSplitFunTy_maybe ty1 - split2 = tcSplitFunTy_maybe ty2 + ; return $ combine_rev (FunTy af1 w1) res_b res_a } + + go ty1@(FunTy {}) ty2 = bale_out ty1 ty2 + go ty1 ty2@(FunTy {}) = bale_out ty1 ty2 go ty1 ty2 - | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2 + | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1 + , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2 = if tc1 == tc2 && tys1 `equalLength` tys2 -- Crucial to check for equal-length args, because -- we cannot assume that the two args to 'go' have @@ -1323,8 +1269,8 @@ zonk_eq_types = go else bale_out ty1 ty2 go ty1 ty2 - | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 + , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 = do { res_a <- go ty1a ty2a ; res_b <- go ty1b ty2b ; return $ combine_rev mkAppTy res_b res_a } @@ -1538,9 +1484,9 @@ can_eq_app ev s1 t1 s2 t2 = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) | CtGiven { ctev_evar = evar } <- ev - = do { let co = mkTcCoVarCo evar - co_s = mkTcLRCo CLeft co - co_t = mkTcLRCo CRight co + = do { let co = mkCoVarCo evar + co_s = mkLRCo CLeft co + co_t = mkLRCo CRight co ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 , evCoercion co_s ) ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 @@ -1551,8 +1497,8 @@ can_eq_app ev s1 t1 s2 t2 where loc = ctEvLoc ev - s1k = tcTypeKind s1 - s2k = tcTypeKind s2 + s1k = typeKind s1 + s2k = typeKind s2 k1 `mismatches` k2 = isForAllTy k1 && not (isForAllTy k2) @@ -1604,12 +1550,13 @@ canTyConApp ev eq_rel tc1 tys1 tc2 tys2 | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational && isGenerativeTyCon tc2 Representational) = canEqFailure ev eq_rel ty1 ty2 + | otherwise = canEqHardFailure ev ty1 ty2 where -- Reconstruct the types for error messages. This would do -- the wrong thing (from a pretty printing point of view) - -- for functions, because we've lost the AnonArgFlag; but + -- for functions, because we've lost the FunTyFlag; but -- in fact we never call canTyConApp on a saturated FunTyCon ty1 = mkTyConApp tc1 tys1 ty2 = mkTyConApp tc2 tys2 @@ -1788,8 +1735,8 @@ Conclusion: It all comes from the fact that newtypes aren't necessarily injective w.r.t. representational equality. -Furthermore, as explained in Note [NthCo and newtypes] in GHC.Core.TyCo.Rep, we can't use -NthCo on representational coercions over newtypes. NthCo comes into play +Furthermore, as explained in Note [SelCo and newtypes] in GHC.Core.TyCo.Rep, we can't use +SelCo on representational coercions over newtypes. SelCo comes into play only when decomposing givens. Conclusion: @@ -1901,7 +1848,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 -> do { let ev_co = mkCoVarCo evar ; given_evs <- newGivenEvVars loc $ [ ( mkPrimEqPredRole r ty1 ty2 - , evCoercion $ mkNthCo r i ev_co ) + , evCoercion $ mkSelCo (SelTyCon i r) ev_co ) | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] , r /= Phantom , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] @@ -1910,11 +1857,11 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 ; stopWith ev "Decomposed TyConApp" } where - loc = ctEvLoc ev - role = eqRelRole eq_rel + loc = ctEvLoc ev + role = eqRelRole eq_rel - -- infinite, as tyConRolesX returns an infinite tail of Nominal - tc_roles = tyConRoleListX role tc + -- Infinite, to allow for over-saturated TyConApps + tc_roles = tyConRoleListX role tc -- Add nuances to the location during decomposition: -- * if the argument is a kind argument, remember this, so that error @@ -1936,6 +1883,38 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 = new_loc0 ] ++ repeat loc +canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag + -> (Type,Type,Type) -- (multiplicity,arg,res) + -> (Type,Type,Type) -- (multiplicity,arg,res) + -> TcS (StopOrContinue Ct) +canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2) + = do { traceTcS "canDecomposableFunTy" + (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2) + ; case ev of + CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } + -> do { mult <- unifyWanted rewriters mult_loc (funRole role SelMult) m1 m2 + ; arg <- unifyWanted rewriters loc (funRole role SelArg) a1 a2 + ; res <- unifyWanted rewriters loc (funRole role SelRes) r1 r2 + ; setWantedEq dest (mkNakedFunCo1 role af mult arg res) } + + CtGiven { ctev_evar = evar } + -> do { let ev_co = mkCoVarCo evar + ; given_evs <- newGivenEvVars loc $ + [ ( mkPrimEqPredRole role' ty1 ty2 + , evCoercion $ mkSelCo (SelFun fs) ev_co ) + | (fs, ty1, ty2) <- [(SelMult, m1, m2) + ,(SelArg, a1, a2) + ,(SelRes, r1, r2)] + , let role' = funRole role fs ] + ; emitWorkNC given_evs } + + ; stopWith ev "Decomposed TyConApp" } + + where + loc = ctEvLoc ev + role = eqRelRole eq_rel + mult_loc = updateCtLocOrigin loc toInvisibleOrigin + -- | Call when canonicalizing an equality fails, but if the equality is -- representational, there is some hope for the future. -- Examples in Note [Use canEqFailure in canDecomposableTyConApp] @@ -2106,7 +2085,7 @@ canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 where k1 = canEqLHSKind lhs1 - k2 = tcTypeKind xi2 + k2 = typeKind xi2 canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) -> EqRel -> SwapFlag @@ -2140,7 +2119,7 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2 mk_kind_eq :: TcS (CtEvidence, CoercionN) mk_kind_eq = case ev of CtGiven { ctev_evar = evar } - -> do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1 + -> do { let kind_co = maybe_sym $ mkKindCo (mkCoVarCo evar) -- :: k2 ~ k1 ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) ; return (kind_ev, ctEvCoercion kind_ev) } @@ -2156,9 +2135,9 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2 maybe_sym = case swapped of IsSwapped -> id -- if the input is swapped, then we already -- will have k2 ~ k1 - NotSwapped -> mkTcSymCo + NotSwapped -> mkSymCo --- guaranteed that tcTypeKind lhs == tcTypeKind rhs +-- guaranteed that typeKind lhs == typeKind rhs canEqCanLHSHomo :: CtEvidence -> EqRel -> SwapFlag -> CanEqLHS -- lhs (or, if swapped, rhs) @@ -2168,7 +2147,7 @@ canEqCanLHSHomo :: CtEvidence canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 | (xi2', mco) <- split_cast_ty xi2 , Just lhs2 <- canEqLHS_maybe xi2' - = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkTcSymMCo mco) mco + = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco | otherwise = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2 @@ -2285,7 +2264,7 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco = finish_without_swapping where - sym_mco = mkTcSymMCo mco + sym_mco = mkSymMCo mco do_swap = rewriteCastedEquality ev eq_rel swapped (canEqLHSType lhs1) (canEqLHSType lhs2) mco finish_without_swapping = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco) @@ -2324,7 +2303,7 @@ canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco (TyFamLHS fun_tc2 fun_args2) (ps_xi1 `mkCastTyMCo` sym_mco) } } where - sym_mco = mkTcSymMCo mco + sym_mco = mkSymMCo mco rhs = ps_xi2 `mkCastTyMCo` mco -- The RHS here is either not CanEqLHS, or it's one that we @@ -2347,7 +2326,7 @@ canEqCanLHSFinish ev eq_rel swapped lhs rhs (mkReflRedn role rhs) -- by now, (TyEq:K) is already satisfied - ; massert (canEqLHSKind lhs `eqType` tcTypeKind rhs) + ; massert (canEqLHSKind lhs `eqType` typeKind rhs) -- by now, (TyEq:N) is already satisfied (if applicable) ; assertPprM ty_eq_N_OK $ @@ -2433,7 +2412,7 @@ canEqReflexive :: CtEvidence -- ty ~ ty -> TcS (StopOrContinue Ct) -- always Stop canEqReflexive ev eq_rel ty = do { setEvBindIfWanted ev (evCoercion $ - mkTcReflCo (eqRelRole eq_rel) ty) + mkReflCo (eqRelRole eq_rel) ty) ; stopWith ev "Solved by reflexivity" } rewriteCastedEquality :: CtEvidence -- :: lhs ~ (rhs |> mco), or (rhs |> mco) ~ lhs @@ -2449,7 +2428,7 @@ rewriteCastedEquality ev eq_rel swapped lhs rhs mco lhs_redn = mkGReflRightMRedn role lhs sym_mco rhs_redn = mkGReflLeftMRedn role rhs mco - sym_mco = mkTcSymMCo mco + sym_mco = mkSymMCo mco role = eqRelRole eq_rel {- Note [Equalities with incompatible kinds] @@ -2986,7 +2965,7 @@ the rewriter set. We check this with an assertion. rewriteEvidence rewriters old_ev (Reduction co new_pred) - | isTcReflCo co -- See Note [Rewriting with Refl] + | isReflCo co -- See Note [Rewriting with Refl] = assert (isEmptyRewriterSet rewriters) $ continueWith (setCtEvPredType old_ev new_pred) @@ -2998,7 +2977,7 @@ rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) where -- mkEvCast optimises ReflCo new_tm = mkEvCast (evId old_evar) - (tcDowngradeRole Representational (ctEvRole ev) co) + (downgradeRole Representational (ctEvRole ev) co) rewriteEvidence new_rewriters ev@(CtWanted { ctev_dest = dest @@ -3006,10 +2985,10 @@ rewriteEvidence new_rewriters , ctev_rewriters = rewriters }) (Reduction co new_pred) = do { mb_new_ev <- newWanted loc rewriters' new_pred - ; massert (tcCoercionRole co == ctEvRole ev) + ; massert (coercionRole co == ctEvRole ev) ; setWantedEvTerm dest (mkEvCast (getEvExpr mb_new_ev) - (tcDowngradeRole Representational (ctEvRole ev) (mkSymCo co))) + (downgradeRole Representational (ctEvRole ev) (mkSymCo co))) ; case mb_new_ev of Fresh new_ev -> continueWith new_ev Cached _ -> stopWith ev "Cached wanted" } @@ -3043,14 +3022,14 @@ rewriteEqEvidence :: RewriterSet -- New rewriters -- It's all a form of rewriteEvidence, specialised for equalities rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) | NotSwapped <- swapped - , isTcReflCo lhs_co -- See Note [Rewriting with Refl] - , isTcReflCo rhs_co + , isReflCo lhs_co -- See Note [Rewriting with Refl] + , isReflCo rhs_co = return (setCtEvPredType old_ev new_pred) | CtGiven { ctev_evar = old_evar } <- old_ev - = do { let new_tm = evCoercion ( mkTcSymCo lhs_co - `mkTcTransCo` maybeTcSymCo swapped (mkTcCoVarCo old_evar) - `mkTcTransCo` rhs_co) + = do { let new_tm = evCoercion ( mkSymCo lhs_co + `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar) + `mkTransCo` rhs_co) ; newGivenEvVar loc' (new_pred, new_tm) } | CtWanted { ctev_dest = dest @@ -3058,10 +3037,10 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio , let rewriters' = rewriters S.<> new_rewriters = do { (new_ev, hole_co) <- newWantedEq loc' rewriters' (ctEvRole old_ev) nlhs nrhs - ; let co = maybeTcSymCo swapped $ + ; let co = maybeSymCo swapped $ lhs_co `mkTransCo` hole_co - `mkTransCo` mkTcSymCo rhs_co + `mkTransCo` mkSymCo rhs_co ; setWantedEq dest co ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev , ppr nlhs @@ -3110,20 +3089,22 @@ unifyWanted :: RewriterSet -> CtLoc -- See Note [unifyWanted] -- The returned coercion's role matches the input parameter unifyWanted rewriters loc Phantom ty1 ty2 - = do { kind_co <- unifyWanted rewriters loc Nominal (tcTypeKind ty1) (tcTypeKind ty2) + = do { kind_co <- unifyWanted rewriters loc Nominal (typeKind ty1) (typeKind ty2) ; return (mkPhantomCo kind_co ty1 ty2) } unifyWanted rewriters loc role orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' + go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 + go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2' - go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) + go (FunTy af1 w1 s1 t1) (FunTy af2 w2 s2 t2) + | af1 == af2 -- Important! See #21530 = do { co_s <- unifyWanted rewriters loc role s1 s2 ; co_t <- unifyWanted rewriters loc role t1 t2 ; co_w <- unifyWanted rewriters loc Nominal w1 w2 - ; return (mkFunCo role co_w co_s co_t) } + ; return (mkNakedFunCo1 role af1 co_w co_s co_t) } + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2, tys1 `equalLength` tys2 , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality @@ -3148,6 +3129,6 @@ unifyWanted rewriters loc role orig_ty1 orig_ty2 go ty1 ty2 = bale_out ty1 ty2 bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1) + | ty1 `tcEqType` ty2 = return (mkReflCo role ty1) -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2 diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs index e95a1debff..a413c06346 100644 --- a/compiler/GHC/Tc/Solver/InertSet.hs +++ b/compiler/GHC/Tc/Solver/InertSet.hs @@ -41,11 +41,11 @@ module GHC.Tc.Solver.InertSet ( import GHC.Prelude -import GHC.Tc.Solver.Types - import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin +import GHC.Tc.Solver.Types import GHC.Tc.Utils.TcType + import GHC.Types.Var import GHC.Types.Var.Env @@ -1626,7 +1626,7 @@ mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc -- like startSolvingByUnification, but allows cbv variables to unify can_unify :: TcTyVar -> MetaInfo -> Type -> Bool can_unify _lhs_tv TyVarTv rhs_ty -- see Example 3 from the Note - | Just rhs_tv <- tcGetTyVar_maybe rhs_ty + | Just rhs_tv <- getTyVar_maybe rhs_ty = case tcTyVarDetails rhs_tv of MetaTv { mtv_info = TyVarTv } -> True MetaTv {} -> False -- could unify with anything diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index 37bf3a9f1d..8db260182d 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -11,21 +11,14 @@ import GHC.Types.Basic ( SwapFlag(..), infinity, IntWithInf, intGtLimit ) import GHC.Tc.Solver.Canonical import GHC.Types.Var.Set -import GHC.Core.Type as Type -import GHC.Core.InstEnv ( DFunInstType ) import GHC.Types.Var import GHC.Tc.Errors.Types import GHC.Tc.Utils.TcType import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) -import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop ) -import GHC.Core.Class -import GHC.Core.TyCon import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap ) -import GHC.Core.FamInstEnv -import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) import GHC.Tc.Types.Evidence import GHC.Utils.Outputable @@ -33,32 +26,46 @@ import GHC.Utils.Panic import GHC.Tc.Types import GHC.Tc.Types.Constraint -import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo ) import GHC.Tc.Solver.Types import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad -import GHC.Data.Bag -import GHC.Utils.Monad ( concatMapM, foldlM ) import GHC.Core -import Data.List( deleteFirstsBy ) -import Data.Function ( on ) +import GHC.Core.Type as Type +import GHC.Core.InstEnv ( DFunInstType ) +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Predicate +import GHC.Core.Coercion +import GHC.Core.FamInstEnv +import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) +import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches + , sfInteractInert, sfInteractTop ) + import GHC.Types.SrcLoc import GHC.Types.Var.Env +import GHC.Types.Unique( hasKey ) -import qualified Data.Semigroup as S -import Control.Monad -import Data.Maybe ( listToMaybe, mapMaybe ) +import GHC.Data.Bag import GHC.Data.Pair (Pair(..)) -import GHC.Types.Unique( hasKey ) -import GHC.Driver.Session + +import GHC.Utils.Monad ( concatMapM, foldlM ) import GHC.Utils.Misc + +import GHC.Driver.Session + import qualified GHC.LanguageExtensions as LangExt +import Data.List( deleteFirstsBy ) +import Data.Maybe ( listToMaybe, mapMaybe ) +import Data.Function ( on ) +import qualified Data.Semigroup as S + import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe +import Control.Monad {- ********************************************************************** @@ -672,7 +679,7 @@ interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_reason = reason }) swap_me swap ev = case swap of NotSwapped -> ctEvTerm ev - IsSwapped -> evCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev))) + IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev))) interactIrred _ wi = pprPanic "interactIrred" (ppr wi) @@ -1523,10 +1530,10 @@ interactEq inerts workItem@(CEqCan { cc_lhs = lhs , cc_eq_rel = eq_rel }) | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem = do { setEvBindIfWanted ev $ - evCoercion (maybeTcSymCo swapped $ - tcDowngradeRole (eqRelRole eq_rel) - (ctEvRole ev_i) - (ctEvCoercion ev_i)) + evCoercion (maybeSymCo swapped $ + downgradeRole (eqRelRole eq_rel) + (ctEvRole ev_i) + (ctEvCoercion ev_i)) ; stopWith ev "Solved from inert" } @@ -1588,10 +1595,10 @@ solveByUnification wd tv xi ; traceTcS "Sneaky unification:" $ vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, text "Coercion:" <+> pprEq tv_ty xi, - text "Left Kind is:" <+> ppr (tcTypeKind tv_ty), - text "Right Kind is:" <+> ppr (tcTypeKind xi) ] + text "Left Kind is:" <+> ppr (typeKind tv_ty), + text "Right Kind is:" <+> ppr (typeKind xi) ] ; unifyTyVar tv xi - ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) + ; setEvBindIfWanted wd (evCoercion (mkNomReflCo xi)) ; n_kicked <- kickOutAfterUnification tv ; return (Stop wd (text "Solved by unification" <+> pprKicked n_kicked)) } @@ -2574,7 +2581,7 @@ impliedBySCs :: TcThetaType -> TcThetaType -> Bool impliedBySCs c1 c2 = all in_c2 c1 where in_c2 :: TcPredType -> Bool - in_c2 pred = any (pred `eqType`) c2_expanded + in_c2 pred = any (pred `tcEqType`) c2_expanded c2_expanded :: [TcPredType] -- Includes all superclasses c2_expanded = [ q | p <- c2, q <- p : transSuperClasses p ] diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 63b5aee2b4..63f8216633 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -131,27 +131,29 @@ import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(.. import qualified GHC.Tc.Utils.Env as TcM ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl , tcInitTidyEnv ) + +import GHC.Driver.Session + import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) import GHC.Tc.Utils.TcType -import GHC.Driver.Session +import GHC.Tc.Solver.Types +import GHC.Tc.Solver.InertSet +import GHC.Tc.Types.Evidence +import GHC.Tc.Errors.Types + import GHC.Core.Type import qualified GHC.Core.TyCo.Rep as Rep -- this needs to be used only very locally import GHC.Core.Coercion import GHC.Core.Reduction - -import GHC.Tc.Solver.Types -import GHC.Tc.Solver.InertSet - -import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Core.TyCon -import GHC.Tc.Errors.Types -import GHC.Types.Error ( mkPlainError, noHints ) +import GHC.Types.Error ( mkPlainError, noHints ) import GHC.Types.Name import GHC.Types.TyThing -import GHC.Unit.Module ( HasModule, getModule, extractModule ) import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) + +import GHC.Unit.Module ( HasModule, getModule, extractModule ) import qualified GHC.Rename.Env as TcM import GHC.Types.Var import GHC.Types.Var.Env @@ -1684,7 +1686,7 @@ setWantedEvTerm (HoleDest hole) tm = -- See Note [Yukky eq_sel for a HoleDest] do { let co_var = coHoleCoVar hole ; setEvBind (mkWantedEvBind co_var tm) - ; fillCoercionHole hole (mkTcCoVarCo co_var) } + ; fillCoercionHole hole (mkCoVarCo co_var) } setWantedEvTerm (EvVarDest ev_id) tm = setEvBind (mkWantedEvBind ev_id tm) @@ -1940,7 +1942,7 @@ breakTyEqCycle_maybe ev cte_result lhs rhs -- causing trouble? See Detail (5) of Note. = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys fun_app = mkTyConApp tc fun_args - fun_app_kind = tcTypeKind fun_app + fun_app_kind = typeKind fun_app ; fun_redn <- emit_work fun_app_kind fun_app ; arg_redns <- unzipRedns <$> mapM go extra_args ; return $ mkAppRedns fun_redn arg_redns } @@ -2010,5 +2012,5 @@ restoreTyVarCycles is rewriterView :: TcType -> Maybe TcType rewriterView ty@(Rep.TyConApp tc _) | isForgetfulSynTyCon tc || (isTypeSynonymTyCon tc && not (isFamFreeTyCon tc)) - = tcView ty + = coreView ty rewriterView _other = Nothing diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs index e746f35e41..33b25f29a7 100644 --- a/compiler/GHC/Tc/Solver/Rewrite.hs +++ b/compiler/GHC/Tc/Solver/Rewrite.hs @@ -40,7 +40,7 @@ import GHC.Data.Maybe import GHC.Exts (oneShot) import Control.Monad import Control.Applicative (liftA3) -import GHC.Builtin.Types.Prim (tYPETyCon) +import GHC.Builtin.Types (tYPETyCon) import Data.List ( find ) import GHC.Data.List.Infinite (Infinite) import qualified GHC.Data.List.Infinite as Inf @@ -277,8 +277,8 @@ rewriteType loc ty Key invariants: (F0) co :: zonk(ty') ~ xi where zonk(ty') ~ zonk(ty) - (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind - (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) + (F1) typeKind(xi) succeeds and returns a fully zonked kind + (F2) typeKind(xi) `eqType` zonk(typeKind(ty)) Note that it is rewrite's job to try to reduce *every type function it sees*. @@ -299,14 +299,14 @@ It is for this reason that we occasionally have to explicitly zonk, when (co :: ty ~ xi) is important even before we zonk the whole program. For example, see the RTRNotFollowed case in rewriteTyVar. -Why have these invariants on rewriting? Because we sometimes use tcTypeKind +Why have these invariants on rewriting? Because we sometimes use typeKind during canonicalisation, and we want this kind to be zonked (e.g., see GHC.Tc.Solver.Canonical.canEqCanLHS). Rewriting is always homogeneous. That is, the kind of the result of rewriting is always the same as the kind of the input, modulo zonking. More formally: - (F2) zonk(tcTypeKind(ty)) `eqType` tcTypeKind(xi) + (F2) zonk(typeKind(ty)) `eqType` typeKind(xi) This invariant means that the kind of a rewritten type might not itself be rewritten. @@ -391,7 +391,7 @@ rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. {-# INLINE rewrite_args #-} -rewrite_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are +rewrite_args :: [PiTyBinder] -> Bool -- Binders, and True iff any of them are -- named. -> Kind -> TcTyCoVarSet -- function kind; kind's free vars -> Maybe (Infinite Role) -> [Type] -- these are in 1-to-1 correspondence @@ -400,7 +400,7 @@ rewrite_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are -- This function returns ArgsReductions (Reductions cos xis) res_co -- coercions: co_i :: ty_i ~ xi_i, at roles given -- types: xi_i --- coercion: res_co :: tcTypeKind(fun tys) ~N tcTypeKind(fun xis) +-- coercion: res_co :: typeKind(fun tys) ~N typeKind(fun xis) -- That is, the result coercion relates the kind of some function (whose kind is -- passed as the first parameter) instantiated at tys to the kind of that -- function instantiated at the xis. This is useful in keeping rewriting @@ -439,7 +439,7 @@ rewrite_args_fast orig_tys {-# INLINE rewrite_args_slow #-} -- | Slow path, compared to rewrite_args_fast, because this one must track -- a lifting context. -rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet +rewrite_args_slow :: [PiTyBinder] -> Kind -> TcTyCoVarSet -> Infinite Role -> [Type] -> RewriteM ArgsReductions rewrite_args_slow binders inner_ki fvs roles tys @@ -591,7 +591,7 @@ rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys do { let tc_roles = tyConRolesRepresentational tc arg_roles = Inf.dropList xis tc_roles ; ArgsReductions (Reductions arg_cos arg_xis) kind_co - <- rewrite_vector (tcTypeKind fun_xi) arg_roles arg_tys + <- rewrite_vector (typeKind fun_xi) arg_roles arg_tys -- We start with a reduction of the form -- fun_co :: ty ~ T xi_1 ... xi_n @@ -608,8 +608,8 @@ rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys app_co = case eq_rel of NomEq -> mkAppCos fun_co arg_cos ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys) - `mkTcTransCo` - mkTcTyConAppCo Representational tc + `mkTransCo` + mkTyConAppCo Representational tc (zipWith mkReflCo (Inf.toList tc_roles) xis ++ arg_cos) ; return $ @@ -618,7 +618,7 @@ rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys kind_co } Nothing -> do { ArgsReductions redns kind_co - <- rewrite_vector (tcTypeKind fun_xi) (Inf.repeat Nominal) arg_tys + <- rewrite_vector (typeKind fun_xi) (Inf.repeat Nominal) arg_tys ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co } ; role <- getRole @@ -1055,7 +1055,7 @@ the new story. -- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at -- least one named binder. -split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) +split_pi_tys' :: Type -> ([PiTyBinder], Type, Bool) split_pi_tys' ty = split ty ty where -- put common cases first @@ -1066,20 +1066,20 @@ split_pi_tys' ty = split ty ty split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) = let -- See #19102 !(bs, ty, named) = split res res - in (Anon af (mkScaled w arg) : bs, ty, named) + in (Anon (mkScaled w arg) af : bs, ty, named) split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' split orig_ty _ = ([], orig_ty, False) {-# INLINE split_pi_tys' #-} --- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff +-- | Like 'tyConBindersPiTyBinders' but you also get a 'Bool' which is true iff -- there is at least one named binder. -ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool) +ty_con_binders_ty_binders' :: [TyConBinder] -> ([PiTyBinder], Bool) ty_con_binders_ty_binders' = foldr go ([], False) where go (Bndr tv (NamedTCB vis)) (bndrs, _) = (Named (Bndr tv vis) : bndrs, True) go (Bndr tv (AnonTCB af)) (bndrs, n) - = (Anon af (tymult (tyVarKind tv)) : bndrs, n) + = (Anon (tymult (tyVarKind tv)) af : bndrs, n) {-# INLINE go #-} {-# INLINE ty_con_binders_ty_binders' #-} diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 605d004834..91e35a86a8 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -107,7 +107,6 @@ import Data.Functor.Identity import Data.List ( partition) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set import Data.Tuple( swap ) {- @@ -982,7 +981,7 @@ promises about the ordering of some variables. These might swizzle around even between minor released. By forbidding visible type application, we ensure users aren't caught unawares. -Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. +Go read Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. The question for this Note is this: given a TyClDecl, how are its quantified type variables classified? @@ -2380,7 +2379,7 @@ wiredInDerivInfo tycon decl , HsDataDefn { dd_derivs = derivs } <- dataDefn = [ DerivInfo { di_rep_tc = tycon , di_scoped_tvs = - if isFunTyCon tycon || isPrimTyCon tycon + if isPrimTyCon tycon then [] -- no tyConTyVars else mkTyVarNamePairs (tyConTyVars tycon) , di_clauses = derivs @@ -3432,8 +3431,8 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map ; let tc_tvs = binderVars tc_bndrs fake_ty = mkSpecForAllTys tc_tvs $ mkInvisForAllTys exp_tvbndrs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ + tcMkPhiTy ctxt $ + tcMkScaledFunTys arg_tys $ unitTy -- That type is a lie, of course. (It shouldn't end in ()!) -- And we could construct a proper result type from the info @@ -3538,8 +3537,8 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map ; tkvs <- kindGeneralizeAll skol_info (mkInvisForAllTys outer_tv_bndrs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ + tcMkPhiTy ctxt $ + tcMkScaledFunTys arg_tys $ res_ty) ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs) ; reportUnsolvedEqualities skol_info tkvs tclvl wanted @@ -3848,10 +3847,12 @@ rejigConRes tc_tvbndrs res_tmpl dc_tvbndrs res_ty -- since the dcUserTyVarBinders invariant guarantees that the -- substitution has *all* the tyvars in its domain. -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - subst_user_tvs = mapVarBndrs (getTyVar "rejigConRes" . substTyVar arg_subst) + subst_user_tvs = mapVarBndrs (substTyVarToTyVar arg_subst) substed_tvbndrs = subst_user_tvs dc_tvbndrs - substed_eqs = map (substEqSpec arg_subst) raw_eqs + substed_eqs = [ mkEqSpec (substTyVarToTyVar arg_subst tv) + (substTy arg_subst ty) + | (tv,ty) <- raw_eqs ] in (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst) @@ -4017,7 +4018,7 @@ mkGADTVars :: [TyVar] -- ^ The tycon vars -> Subst -- ^ The matching between the template result type -- and the actual result type -> ( [TyVar] - , [EqSpec] + , [(TyVar,Type)] -- The un-substituted eq-spec , Subst ) -- ^ The univ. variables, the GADT equalities, -- and a subst to apply to the GADT equalities -- and existentials. @@ -4028,13 +4029,13 @@ mkGADTVars tmpl_tvs dc_tvs subst `unionInScope` getSubstInScope subst empty_subst = mkEmptySubst in_scope - choose :: [TyVar] -- accumulator of univ tvs, reversed - -> [EqSpec] -- accumulator of GADT equalities, reversed + choose :: [TyVar] -- accumulator of univ tvs, reversed + -> [(TyVar,Type)] -- accumulator of GADT equalities, reversed -> Subst -- template substitution -> Subst -- res. substitution -> [TyVar] -- template tvs (the univ tvs passed in) -> ( [TyVar] -- the univ_tvs - , [EqSpec] -- GADT equalities + , [(TyVar,Type)] -- GADT equalities , Subst ) -- a substitution to fix kinds in ex_tvs choose univs eqs _t_sub r_sub [] @@ -4046,6 +4047,8 @@ mkGADTVars tmpl_tvs dc_tvs subst | not (r_tv `elem` univs) , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) -> -- simple, well-kinded variable substitution. + -- the name of the universal comes from the result of the ctor + -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon choose (r_tv:univs) eqs (extendTvSubst t_sub t_tv r_ty') (extendTvSubst r_sub r_tv r_ty') @@ -4055,13 +4058,19 @@ mkGADTVars tmpl_tvs dc_tvs subst r_ty' = mkTyVarTy r_tv1 -- Not a simple substitution: make an equality predicate - _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs) + -- the name of the universal comes from the datatype header + -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon + _ -> choose (t_tv':univs) eqs' (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) -- We've updated the kind of t_tv, -- so add it to t_sub (#14162) r_sub t_tvs where - t_tv' = updateTyVarKind (substTy t_sub) t_tv + tv_kind = tyVarKind t_tv + tv_kind' = substTy t_sub tv_kind + t_tv' = setTyVarKind t_tv tv_kind' + eqs' | isConstraintLikeKind (typeKind tv_kind') = eqs + | otherwise = (t_tv', r_ty) : eqs | otherwise = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) @@ -4344,9 +4353,7 @@ checkPartialRecordField all_cons fld is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field con1 = assert (not (null cons_with_field)) $ head cons_with_field - (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1 - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - inst_tys = substTyVars eq_subst univ_tvs + inst_tys = dataConResRepTyArgs con1 checkFieldCompat :: FieldLabelString -> DataCon -> DataCon -> Type -> Type -> Type -> Type -> TcM () @@ -4369,8 +4376,8 @@ checkValidDataCon dflags existential_ok tc con ; traceTc "checkValidDataCon" (vcat [ ppr con, ppr tc, ppr tc_tvs - , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl) - , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)]) + , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) + , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) -- Check that the return type of the data constructor @@ -4500,17 +4507,8 @@ checkValidDataCon dflags existential_ok tc con -- checked here because we sometimes build invalid DataCons before -- erroring above here ; when debugIsOn $ - do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con - user_tvs = dataConUserTyVars con - user_tvbs_invariant - = Set.fromList (filterEqSpec eq_spec univs ++ exs) - == Set.fromList user_tvs - ; massertPpr user_tvbs_invariant - $ vcat ([ ppr con - , ppr univs - , ppr exs - , ppr eq_spec - , ppr user_tvs ]) } + massertPpr (checkDataConTyVars con) $ + ppr con $$ ppr (dataConFullSig con) $$ ppr (dataConUserTyVars con) ; traceTc "Done validity of data con" $ vcat [ ppr con @@ -4576,8 +4574,8 @@ checkNewDataCon con ok_bang (HsSrcBang _ _ SrcLazy) = False ok_bang _ = True - ok_mult One = True - ok_mult _ = False + ok_mult OneTy = True + ok_mult _ = False -- | Reject nullary data constructors where a type variable @@ -4586,7 +4584,7 @@ checkNewDataCon con checkEscapingKind :: DataCon -> TcM () checkEscapingKind data_con | null eq_spec, null theta, null arg_tys - , let tau_kind = tcTypeKind res_ty + , let tau_kind = typeKind res_ty , Nothing <- occCheckExpand (univ_tvs ++ ex_tvs) tau_kind -- Ensure that none of the tvs occur in the kind of the forall -- /after/ expanding type synonyms. @@ -5098,7 +5096,7 @@ checkValidRoles tc check_dc_roles datacon = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) ; mapM_ (check_ty_roles role_env Representational) $ - eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) } + eqSpecPreds eq_spec ++ theta ++ map scaledThing arg_tys } -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils where (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index 19d79bc0a7..e7d423f2e1 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -18,26 +18,29 @@ module GHC.Tc.TyCl.Build ( import GHC.Prelude import GHC.Iface.Env -import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) import GHC.Builtin.Types( isCTupleTyConName, unboxedUnitTy ) + +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad + import GHC.Core.DataCon import GHC.Core.PatSyn +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) + +import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Type import GHC.Types.SourceText -import GHC.Tc.Utils.TcType -import GHC.Core.Multiplicity - -import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) -import GHC.Tc.Utils.Monad import GHC.Types.Unique.Supply + import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -175,7 +178,7 @@ buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs data_con = mkDataCon src_name declared_infix prom_info src_bangs field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt - arg_tys res_ty NoRRI rep_tycon tag + arg_tys res_ty NoPromInfo rep_tycon tag stupid_ctxt dc_wrk dc_rep dc_wrk = mkDataConWorkId work_name data_con dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) @@ -320,22 +323,20 @@ buildClass tycon_name binders roles fds -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - ; let use_newtype = isSingleton arg_tys + ; let use_newtype = isSingleton (sc_theta ++ op_tys) -- Use a newtype if the data constructor -- (a) has exactly one value field -- i.e. exactly one operation or superclass taken together -- (b) that value is of lifted type (which they always are, because -- we box equality superclasses) -- See Note [Class newtypes and equality predicates] - - -- We treat the dictionary superclasses as ordinary arguments. - -- That means that in the case of + -- + -- In the case of -- class C a => D a - -- we don't get a newtype with no arguments! + -- we use a newtype, but with one superclass and no arguments args = sc_sel_names ++ op_names op_tys = [ty | (_,ty,_) <- sig_stuff] op_names = [op | (op,_,_) <- sig_stuff] - arg_tys = sc_theta ++ op_tys rec_tycon = classTyCon rec_clas univ_bndrs = tyConInvisTVBinders binders univ_tvs = binderVars univ_bndrs @@ -353,8 +354,8 @@ buildClass tycon_name binders roles fds [{- no existentials -}] univ_bndrs [{- No GADT equalities -}] - [{- No theta -}] - (map unrestricted arg_tys) -- type classes are unrestricted + sc_theta + (map unrestricted op_tys) -- type classes are unrestricted (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) rec_tycon (mkTyConTagMap rec_tycon) diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index 4cb0e9d2c0..9da7b05192 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -290,7 +290,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ctxt = FunSigCtxt sel_name warn_redundant - ; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty + ; let local_dm_id = mkLocalId local_dm_name ManyTy local_dm_ty local_dm_sig = CompleteSig { sig_bndr = local_dm_id , sig_ctxt = ctxt , sig_loc = getLocA hs_ty } diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index c5bb704b41..06a06a0fad 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -498,8 +498,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds -- Map from the skolemized Names to the original Names. -- See Note [Associated data family instances and di_scoped_tvs]. tv_skol_env = mkVarEnv $ map swap tv_skol_prs - n_inferred = countWhile ((== Inferred) . binderArgFlag) $ - fst $ splitForAllTyCoVarBinders dfun_ty + n_inferred = countWhile ((== Inferred) . binderFlag) $ + fst $ splitForAllForAllTyBinders dfun_ty visible_skol_tvs = drop n_inferred skol_tvs ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs) @@ -1468,9 +1468,8 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) ; sc_ev_id <- newEvVar sc_pred ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm - ; let sc_top_ty = mkInfForAllTys tyvars $ - mkPhiTy (map idType dfun_evs) sc_pred - sc_top_id = mkLocalId sc_top_name Many sc_top_ty + ; let sc_top_ty = tcMkDFunSigmaTy tyvars (map idType dfun_evs) sc_pred + sc_top_id = mkLocalId sc_top_name ManyTy sc_top_ty export = ABE { abe_wrap = idHsWrapper , abe_poly = sc_top_id , abe_mono = sc_ev_id @@ -1783,7 +1782,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys meth_tau = classMethodInstTy sel_id inst_tys error_string dflags = showSDoc dflags (hcat [ppr inst_loc, vbar, ppr sel_id ]) - lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars + lam_wrapper = mkWpTyLams tyvars <.> mkWpEvLams dfun_ev_vars ---------------------- -- Check if one of the minimal complete definitions is satisfied @@ -1954,7 +1953,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind ; let ctxt = FunSigCtxt sel_name (lhsSigTypeContextSpan hs_sig_ty) -- WantRCC <=> check for redundant constraints in the -- user-specified instance signature - inner_meth_id = mkLocalId inner_meth_name Many sig_ty + inner_meth_id = mkLocalId inner_meth_name ManyTy sig_ty inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id , sig_ctxt = ctxt , sig_loc = getLocA hs_sig_ty } @@ -2003,8 +2002,8 @@ mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; local_meth_name <- newName sel_occ -- Base the local_meth_name on the selector name, because -- type errors from tcMethodBody come from here - ; let poly_meth_id = mkLocalId poly_meth_name Many poly_meth_ty - local_meth_id = mkLocalId local_meth_name Many local_meth_ty + ; let poly_meth_id = mkLocalId poly_meth_name ManyTy poly_meth_ty + local_meth_id = mkLocalId local_meth_name ManyTy local_meth_ty ; return (poly_meth_id, local_meth_id) } where @@ -2115,7 +2114,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name fn = noLocA (idName sel_id) visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys - , tyConBinderArgFlag tcb /= Inferred ] + , tyConBinderForAllTyFlag tcb /= Inferred ] rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys bind = L (noAnnSrcSpan loc) $ mkTopFunBind Generated fn diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index a448d550ac..fdc4e59f1e 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -21,17 +21,27 @@ where import GHC.Prelude import GHC.Hs + import GHC.Tc.Gen.Pat -import GHC.Core.Multiplicity -import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType, isManyDataConTy ) -import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Zonk import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv , addInlinePrags, addInlinePragArity ) -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build + +import GHC.Core.Multiplicity +import GHC.Core.Type ( typeKind, tidyForAllTyBinders, tidyTypes, tidyType, isManyTy, mkTYPEapp ) +import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) +import GHC.Core.Predicate + import GHC.Builtin.Types.Prim import GHC.Types.Error import GHC.Types.Name @@ -47,14 +57,7 @@ import GHC.Types.Id import GHC.Types.Id.Info( RecSelParent(..) ) import GHC.Tc.Gen.Bind import GHC.Types.Basic -import GHC.Tc.Solver -import GHC.Tc.Utils.Unify -import GHC.Core.Predicate import GHC.Builtin.Types -import GHC.Tc.Utils.TcType -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Origin -import GHC.Tc.TyCl.Build import GHC.Types.Var.Set import GHC.Tc.TyCl.Utils import GHC.Core.ConLike @@ -214,8 +217,8 @@ mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) -- See Note [Equality evidence in pattern synonyms] mkProvEvidence ev_id | EqPred r ty1 ty2 <- classifyPredType pred - , let k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 + , let k1 = typeKind ty1 + k2 = typeKind ty2 is_homo = k1 `tcEqType` k2 homo_tys = [k1, ty1, ty2] hetero_tys = [k1, k2, ty1, ty2] @@ -422,7 +425,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ex_tvs = binderVars ex_bndrs -- Pattern synonyms currently cannot be linear (#18806) - ; checkTc (all (isManyDataConTy . scaledMult) arg_tys) $ + ; checkTc (all (isManyTy . scaledMult) arg_tys) $ TcRnLinearPatSyn sig_body_ty ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty []) @@ -718,8 +721,8 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty ; arg_tys' <- zonkTcTypesToTypesX ze arg_tys - ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyTyCoVarBinders env1 ex_tvs' + ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs' + (env2, ex_tvs) = tidyForAllTyBinders env1 ex_tvs' req_theta = tidyTypes env2 req_theta' prov_theta = tidyTypes env2 prov_theta' arg_tys = tidyTypes env2 arg_tys' @@ -803,9 +806,9 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn fail_ty = mkVisFunTyMany unboxedUnitTy res_ty ; matcher_name <- newImplicitBinder ps_name mkMatcherOcc - ; scrutinee <- newSysLocalId (fsLit "scrut") Many pat_ty - ; cont <- newSysLocalId (fsLit "cont") Many cont_ty - ; fail <- newSysLocalId (fsLit "fail") Many fail_ty + ; scrutinee <- newSysLocalId (fsLit "scrut") ManyTy pat_ty + ; cont <- newSysLocalId (fsLit "cont") ManyTy cont_ty + ; fail <- newSysLocalId (fsLit "fail") ManyTy fail_ty ; dflags <- getDynFlags ; let matcher_tau = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index e071a7c7a2..8fb91d9a74 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -139,14 +139,15 @@ synonymTyConsOfType ty go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs go_co (AppCo co co') = go_co co `plusNameEnv` go_co co' go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (FunCo _ co_mult co co') = go_co co_mult `plusNameEnv` go_co co `plusNameEnv` go_co co' + go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r }) + = go_co m `plusNameEnv` go_co a `plusNameEnv` go_co r go_co (CoVarCo _) = emptyNameEnv go_co (HoleCo {}) = emptyNameEnv go_co (AxiomInstCo _ _ cs) = go_co_s cs go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty' go_co (SymCo co) = go_co co go_co (TransCo co co') = go_co co `plusNameEnv` go_co co' - go_co (NthCo _ _ co) = go_co co + go_co (SelCo _ co) = go_co co go_co (LRCo _ co) = go_co co go_co (InstCo co co') = go_co co `plusNameEnv` go_co co' go_co (KindCo co) = go_co co @@ -500,8 +501,8 @@ initialRoleEnv1 hsc_src annots_env tc | otherwise = pprPanic "initialRoleEnv1" (ppr tc) where name = tyConName tc bndrs = tyConBinders tc - argflags = map tyConBinderArgFlag bndrs - num_exps = count isVisibleArgFlag argflags + argflags = map tyConBinderForAllTyFlag bndrs + num_exps = count isVisibleForAllTyFlag argflags -- if the number of annotations in the role annotation decl -- is wrong, just ignore it. We check this in the validity check. @@ -513,7 +514,7 @@ initialRoleEnv1 hsc_src annots_env tc default_roles = build_default_roles argflags role_annots build_default_roles (argf : argfs) (m_annot : ras) - | isVisibleArgFlag argf + | isVisibleForAllTyFlag argf = (m_annot `orElse` default_role) : build_default_roles argfs ras build_default_roles (_argf : argfs) ras = Nominal : build_default_roles argfs ras @@ -902,12 +903,17 @@ mkOneRecordSelector all_cons idDetails fl has_sel con1 = assert (not (null cons_w_field)) $ head cons_w_field -- Selector type; Note [Polymorphic selectors] - field_ty = conLikeFieldType con1 lbl - data_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $ - conLikeUserTyVarBinders con1 - data_tv_set= tyCoVarsOfTypes inst_tys + field_ty = conLikeFieldType con1 lbl + data_tv_set = tyCoVarsOfTypes (data_ty : req_theta) + data_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $ + conLikeUserTyVarBinders con1 + + -- is_naughty: see Note [Naughty record selectors] is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) - || has_sel == NoFieldSelectors + || has_sel == NoFieldSelectors -- No field selectors => all are naughty + -- thus suppressing making a binding + -- A slight hack! + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] | otherwise = mkForAllTys (tyVarSpecToBinders data_tvbs) $ -- Urgh! See Note [The stupid context] in GHC.Core.DataCon @@ -965,23 +971,12 @@ mkOneRecordSelector all_cons idDetails fl has_sel -- B :: { fld :: Int } -> T Int Char dealt_with :: ConLike -> Bool dealt_with (PatSynCon _) = False -- We can't predict overlap - dealt_with con@(RealDataCon dc) = - con `elem` cons_w_field || dataConCannotMatch inst_tys dc - - (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 + dealt_with con@(RealDataCon dc) + = con `elem` cons_w_field || dataConCannotMatch inst_tys dc + where + inst_tys = dataConResRepTyArgs dc - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - -- inst_tys corresponds to one of the following: - -- - -- * The arguments to the user-written return type (for GADT constructors). - -- In this scenario, eq_subst provides a mapping from the universally - -- quantified type variables to the argument types. Note that eq_subst - -- does not need to be applied to any other part of the DataCon - -- (see Note [The dcEqSpec domain invariant] in GHC.Core.DataCon). - -- * The universally quantified type variables - -- (for Haskell98-style constructors and pattern synonyms). In these - -- scenarios, eq_subst is an empty substitution. - inst_tys = substTyVars eq_subst univ_tvs + (_, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1 unit_rhs = mkLHsTupleExpr [] noExtField msg_lit = HsStringPrim NoSourceText (bytesFS (field_label lbl)) @@ -1042,9 +1037,28 @@ helpfully, rather than saying unhelpfully that 'x' is not in scope. Hence the sel_naughty flag, to identify record selectors that don't really exist. In general, a field is "naughty" if its type mentions a type variable that -isn't in the result type of the constructor. Note that this *allows* -GADT record selectors (Note [GADT record selectors]) whose types may look -like sel :: T [a] -> a +isn't in + * the (original, user-written) result type of the constructor, or + * the "required theta" for the constructor + +Note that this *allows* GADT record selectors (Note [GADT record +selectors]) whose types may look like sel :: T [a] -> a + +The "required theta" part is illustrated by test patsyn/should_run/records_run +where we have + + pattern ReadP :: Read a => a -> String + pattern ReadP {readp} <- (read -> readp) + +The selector is defined like this: + + $selreadp :: ReadP a => String -> a + $selReadP s = readp s + +Perfectly fine! The (ReadP a) constraint lets us contructor a value +of type 'a' from a bare String. NB: "required theta" is empty for +data cons (see conLikeFullSig), so this reasoning only bites for +patttern synonyms. For naughty selectors we make a dummy binding sel = () diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs index ea2a5f7189..572efd34d4 100644 --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -234,7 +234,7 @@ data Ct -- Note [CEqCan occurs check] -- * (TyEq:F) rhs has no foralls -- (this avoids substituting a forall for the tyvar in other types) - -- * (TyEq:K) tcTypeKind lhs `tcEqKind` tcTypeKind rhs; Note [Ct kind invariant] + -- * (TyEq:K) typeKind lhs `tcEqKind` typeKind rhs; Note [Ct kind invariant] -- * (TyEq:N) If the equality is representational, rhs is not headed by a saturated -- application of a newtype TyCon. -- See Note [No top-level newtypes on RHS of representational equalities] @@ -385,7 +385,7 @@ data NotConcreteReason | ContainsCast TcType TcCoercionN -- | The type contains a forall. - | ContainsForall TyCoVarBinder TcType + | ContainsForall ForAllTyBinder TcType -- | The type contains a 'CoercionTy'. | ContainsCoercionTy TcCoercion @@ -694,7 +694,7 @@ instance Outputable Ct where -- Does not look through type synonyms. canEqLHS_maybe :: Xi -> Maybe CanEqLHS canEqLHS_maybe xi - | Just tv <- tcGetTyVar_maybe xi + | Just tv <- getTyVar_maybe xi = Just $ TyVarLHS tv | Just (tc, args) <- tcSplitTyConApp_maybe xi @@ -1893,7 +1893,7 @@ ctEvExpr ev = evId (ctEvEvId ev) ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion ctEvCoercion (CtGiven { ctev_evar = ev_id }) - = mkTcCoVarCo ev_id + = mkCoVarCo ev_id ctEvCoercion (CtWanted { ctev_dest = dest }) | HoleDest hole <- dest = -- ctEvCoercion is only called on type equalities @@ -1927,23 +1927,17 @@ arisesFromGivens ct = isGivenCt ct || isGivenLoc (ctLoc ct) -- the evidence and the ctev_pred in sync with each other. -- See Note [CtEvidence invariants]. setCtEvPredType :: HasDebugCallStack => CtEvidence -> Type -> CtEvidence -setCtEvPredType old_ctev new_pred - = case old_ctev of - CtGiven { ctev_evar = ev, ctev_loc = loc } -> - CtGiven { ctev_pred = new_pred - , ctev_evar = setVarType ev new_pred - , ctev_loc = loc - } - CtWanted { ctev_dest = dest, ctev_loc = loc, ctev_rewriters = rewriters } -> - CtWanted { ctev_pred = new_pred - , ctev_dest = new_dest - , ctev_loc = loc - , ctev_rewriters = rewriters - } - where - new_dest = case dest of - EvVarDest ev -> EvVarDest (setVarType ev new_pred) - HoleDest h -> HoleDest (setCoHoleType h new_pred) +setCtEvPredType old_ctev@(CtGiven { ctev_evar = ev }) new_pred + = old_ctev { ctev_pred = new_pred + , ctev_evar = setVarType ev new_pred } + +setCtEvPredType old_ctev@(CtWanted { ctev_dest = dest }) new_pred + = old_ctev { ctev_pred = new_pred + , ctev_dest = new_dest } + where + new_dest = case dest of + EvVarDest ev -> EvVarDest (setVarType ev new_pred) + HoleDest h -> HoleDest (setCoHoleType h new_pred) instance Outputable TcEvDest where ppr (HoleDest h) = text "hole" <> ppr h diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index 87e6bc5b82..5d69962865 100644 --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -8,7 +8,7 @@ module GHC.Tc.Types.Evidence ( -- * HsWrapper HsWrapper(..), (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, - mkWpLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, + mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, collectHsWrapBinders, idHsWrapper, isIdHsWrapper, pprHsWrapper, hsWrapDictBinders, @@ -41,22 +41,7 @@ module GHC.Tc.Types.Evidence ( TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, TcMCoercion, TcMCoercionN, TcMCoercionR, Role(..), LeftOrRight(..), pickLR, - mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, - mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, - mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, - mkTcSymCo, mkTcSymMCo, - mkTcTransCo, - mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSymCo, - maybeTcSubCo, tcDowngradeRole, - mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflRightMCo, mkTcGReflLeftCo, mkTcGReflLeftMCo, - mkTcPhantomCo, - mkTcCoherenceLeftCo, - mkTcCoherenceRightCo, - mkTcKindCo, - tcCoercionKind, - mkTcCoVarCo, - isTcReflCo, isTcReflexiveCo, - tcCoercionRole, + maybeSymCo, unwrapIP, wrapIP, -- * QuoteWrapper @@ -68,6 +53,7 @@ import GHC.Prelude import GHC.Types.Unique.DFM import GHC.Types.Unique.FM import GHC.Types.Var +import GHC.Types.Id( idScaledType ) import GHC.Core.Coercion.Axiom import GHC.Core.Coercion import GHC.Core.Ppr () -- Instance OutputableBndr TyVar @@ -79,15 +65,12 @@ import GHC.Builtin.Names import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Predicate -import GHC.Data.Pair import GHC.Types.Basic import GHC.Core import GHC.Core.Class (Class, classSCSelId ) import GHC.Core.FVs ( exprSomeFreeVars ) -import GHC.Iface.Type - import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable @@ -118,97 +101,18 @@ kosher free variables. -} -type TcCoercion = Coercion -type TcCoercionN = CoercionN -- A Nominal coercion ~N -type TcCoercionR = CoercionR -- A Representational coercion ~R -type TcCoercionP = CoercionP -- a phantom coercion +type TcCoercion = Coercion +type TcCoercionN = CoercionN -- A Nominal coercion ~N +type TcCoercionR = CoercionR -- A Representational coercion ~R +type TcCoercionP = CoercionP -- a phantom coercion type TcMCoercion = MCoercion type TcMCoercionN = MCoercionN -- nominal type TcMCoercionR = MCoercionR -- representational -mkTcReflCo :: Role -> TcType -> TcCoercion -mkTcSymCo :: TcCoercion -> TcCoercion -mkTcSymMCo :: TcMCoercion -> TcMCoercion -mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion -mkTcNomReflCo :: TcType -> TcCoercionN -mkTcRepReflCo :: TcType -> TcCoercionR -mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion -mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion -mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion -> TcCoercion -mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex - -> [TcType] -> [TcCoercion] -> TcCoercion -mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] - -> [TcCoercion] -> TcCoercionR -mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion -mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion -mkTcNthCo :: Role -> Int -> TcCoercion -> TcCoercion -mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion -mkTcSubCo :: HasDebugCallStack => TcCoercionN -> TcCoercionR -tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion -mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR -mkTcGReflRightCo :: Role -> TcType -> TcCoercionN -> TcCoercion -mkTcGReflRightMCo :: Role -> TcType -> TcMCoercionN -> TcCoercion -mkTcGReflLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion -mkTcGReflLeftMCo :: Role -> TcType -> TcMCoercionN -> TcCoercion -mkTcCoherenceLeftCo :: Role -> TcType -> TcCoercionN - -> TcCoercion -> TcCoercion -mkTcCoherenceRightCo :: Role -> TcType -> TcCoercionN - -> TcCoercion -> TcCoercion -mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP -mkTcKindCo :: TcCoercion -> TcCoercionN -mkTcCoVarCo :: CoVar -> TcCoercion - -tcCoercionKind :: TcCoercion -> Pair TcType -tcCoercionRole :: TcCoercion -> Role -isTcReflCo :: TcCoercion -> Bool - --- | This version does a slow check, calculating the related types and seeing --- if they are equal. -isTcReflexiveCo :: TcCoercion -> Bool - -mkTcReflCo = mkReflCo -mkTcSymCo = mkSymCo -mkTcSymMCo = mkSymMCo -mkTcTransCo = mkTransCo -mkTcNomReflCo = mkNomReflCo -mkTcRepReflCo = mkRepReflCo -mkTcTyConAppCo = mkTyConAppCo -mkTcAppCo = mkAppCo -mkTcFunCo = mkFunCo -mkTcAxInstCo = mkAxInstCo -mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational -mkTcForAllCo = mkForAllCo -mkTcForAllCos = mkForAllCos -mkTcNthCo = mkNthCo -mkTcLRCo = mkLRCo -mkTcSubCo = mkSubCo -tcDowngradeRole = downgradeRole -mkTcAxiomRuleCo = mkAxiomRuleCo -mkTcGReflRightCo = mkGReflRightCo -mkTcGReflRightMCo = mkGReflRightMCo -mkTcGReflLeftCo = mkGReflLeftCo -mkTcGReflLeftMCo = mkGReflLeftMCo -mkTcCoherenceLeftCo = mkCoherenceLeftCo -mkTcCoherenceRightCo = mkCoherenceRightCo -mkTcPhantomCo = mkPhantomCo -mkTcKindCo = mkKindCo -mkTcCoVarCo = mkCoVarCo - -tcCoercionKind = coercionKind -tcCoercionRole = coercionRole -isTcReflCo = isReflCo -isTcReflexiveCo = isReflexiveCo - --- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. --- Note that the input coercion should always be nominal. -maybeTcSubCo :: HasDebugCallStack => EqRel -> TcCoercionN -> TcCoercion -maybeTcSubCo NomEq = id -maybeTcSubCo ReprEq = mkTcSubCo - -- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion -maybeTcSymCo :: SwapFlag -> TcCoercion -> TcCoercion -maybeTcSymCo IsSwapped co = mkTcSymCo co -maybeTcSymCo NotSwapped co = co +maybeSymCo :: SwapFlag -> TcCoercion -> TcCoercion +maybeSymCo IsSwapped co = mkSymCo co +maybeSymCo NotSwapped co = co {- %************************************************************************ @@ -241,7 +145,10 @@ data HsWrapper -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) ~> (exp_arg -> exp_res) -- This isn't the same as for mkFunCo, but it has to be this way -- because we can't use 'sym' to flip around these HsWrappers - -- The TcType is the "from" type of the first wrapper + -- The TcType is the "from" type of the first wrapper; + -- it always a Type, not a Constraint + -- + -- NB: a WpFun is always for a (->) function arrow -- -- Use 'mkWpFun' to construct such a wrapper. @@ -251,8 +158,11 @@ data HsWrapper -- Evidence abstraction and application -- (both dictionaries and coercions) + -- Both WpEvLam and WpEvApp abstract and apply values + -- of kind CONSTRAINT rep | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint + -- Kind and Type abstraction and application | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) @@ -297,29 +207,42 @@ c1 <.> c2 = c1 `WpCompose` c2 mkWpFun :: HsWrapper -> HsWrapper -> Scaled TcTypeFRR -- ^ the "from" type of the first wrapper -- MUST have a fixed RuntimeRep - -> TcType -- ^ either type of the second wrapper (used only when the - -- second wrapper is the identity) + -> TcType -- ^ Either "from" type or "to" type of the second wrapper + -- (used only when the second wrapper is the identity) -> HsWrapper -- NB: we can't check that the argument type has a fixed RuntimeRep with an assertion, -- because of [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] -- in GHC.Tc.Utils.Concrete. mkWpFun WpHole WpHole _ _ = WpHole -mkWpFun WpHole (WpCast co2) (Scaled w t1) _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2) -mkWpFun (WpCast co1) WpHole (Scaled w _) t2 = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2)) -mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2) +mkWpFun WpHole (WpCast co2) (Scaled w t1) _ = WpCast (mk_wp_fun_co w (mkRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole (Scaled w _) t2 = WpCast (mk_wp_fun_co w (mkSymCo co1) (mkRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ = WpCast (mk_wp_fun_co w (mkSymCo co1) co2) mkWpFun co1 co2 t1 _ = WpFun co1 co2 t1 +mkWpEta :: [Id] -> HsWrapper -> HsWrapper +-- (mkWpEta [x1, x2] wrap) [e] +-- = \x1. \x2. wrap[e x1 x2] +-- Just generates a bunch of WpFuns +mkWpEta xs wrap = foldr eta_one wrap xs + where + eta_one x wrap = WpFun idHsWrapper wrap (idScaledType x) + +mk_wp_fun_co :: Mult -> TcCoercionR -> TcCoercionR -> TcCoercionR +mk_wp_fun_co mult arg_co res_co + = mkNakedFunCo1 Representational FTF_T_T (multToCo mult) arg_co res_co + -- FTF_T_T: WpFun is always (->) + mkWpCastR :: TcCoercionR -> HsWrapper mkWpCastR co - | isTcReflCo co = WpHole - | otherwise = assertPpr (tcCoercionRole co == Representational) (ppr co) $ - WpCast co + | isReflCo co = WpHole + | otherwise = assertPpr (coercionRole co == Representational) (ppr co) $ + WpCast co mkWpCastN :: TcCoercionN -> HsWrapper mkWpCastN co - | isTcReflCo co = WpHole - | otherwise = assertPpr (tcCoercionRole co == Nominal) (ppr co) $ - WpCast (mkTcSubCo co) + | isReflCo co = WpHole + | otherwise = assertPpr (coercionRole co == Nominal) (ppr co) $ + WpCast (mkSubCo co) -- The mkTcSubCo converts Nominal to Representational mkWpTyApps :: [Type] -> HsWrapper @@ -334,8 +257,8 @@ mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs) mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids -mkWpLams :: [Var] -> HsWrapper -mkWpLams ids = mk_co_lam_fn WpEvLam ids +mkWpEvLams :: [Var] -> HsWrapper +mkWpEvLams ids = mk_co_lam_fn WpEvLam ids mkWpLet :: TcEvBinds -> HsWrapper -- This no-op is a quite a common case @@ -857,10 +780,10 @@ Important Details: mkEvCast :: EvExpr -> TcCoercion -> EvTerm mkEvCast ev lco - | assertPpr (tcCoercionRole lco == Representational) + | assertPpr (coercionRole lco == Representational) (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]) $ - isTcReflCo lco = EvExpr ev - | otherwise = evCast ev lco + isReflCo lco = EvExpr ev + | otherwise = evCast ev lco mkEvScSelectors -- Assume class (..., D ty, ...) => C a b @@ -1038,10 +961,12 @@ instance Outputable EvCallStack where = ppr (orig,loc) <+> text ":" <+> ppr tm instance Outputable EvTypeable where - ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts - ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) - ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> mulArrow (const ppr) tm <+> ppr t2) - ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 + ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts + ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) + ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 + ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> arr <+> ppr t2) + where + arr = pprArrowWithMultiplicity visArgTypeLike (Right (ppr tm)) ---------------------------------------------------------------------- diff --git a/compiler/GHC/Tc/Utils/Concrete.hs b/compiler/GHC/Tc/Utils/Concrete.hs index da9efb7ef3..95f2a026a7 100644 --- a/compiler/GHC/Tc/Utils/Concrete.hs +++ b/compiler/GHC/Tc/Utils/Concrete.hs @@ -18,16 +18,16 @@ import GHC.Prelude import GHC.Builtin.Types ( liftedTypeKindTyCon, unliftedTypeKindTyCon ) -import GHC.Core.Coercion ( coToMCo, mkCastTyMCo ) +import GHC.Core.Coercion ( coToMCo, mkCastTyMCo + , mkGReflRightMCo, mkNomReflCo ) import GHC.Core.TyCo.Rep ( Type(..), MCoercion(..) ) import GHC.Core.TyCon ( isConcreteTyCon ) -import GHC.Core.Type ( isConcrete, typeKind, tyVarKind, tcView +import GHC.Core.Type ( isConcrete, typeKind, tyVarKind, coreView , mkTyVarTy, mkTyConApp, mkFunTy, mkAppTy ) import GHC.Tc.Types ( TcM, ThStage(..), PendingStuff(..) ) import GHC.Tc.Types.Constraint ( NotConcreteError(..), NotConcreteReason(..) ) -import GHC.Tc.Types.Evidence ( Role(..), TcCoercionN, TcMCoercionN - , mkTcGReflRightMCo, mkTcNomReflCo ) +import GHC.Tc.Types.Evidence ( Role(..), TcCoercionN, TcMCoercionN ) import GHC.Tc.Types.Origin ( CtOrigin(..), FixedRuntimeRepContext, FixedRuntimeRepOrigin(..) ) import GHC.Tc.Utils.Monad ( emitNotConcreteError, setTcLevel, getCtLocM, getStage, traceTc ) import GHC.Tc.Utils.TcType ( TcType, TcKind, TcTypeFRR @@ -455,12 +455,12 @@ checkFRR_with check_kind frr_ctxt ty -- Otherwise: ensure that the kind 'ki' of 'ty' is concrete. | otherwise -> do { kco <- check_kind frr_orig ki - ; return ( mkTcGReflRightMCo Nominal ty kco + ; return ( mkGReflRightMCo Nominal ty kco , mkCastTyMCo ty kco ) } } where refl :: (TcCoercionN, TcType) - refl = (mkTcNomReflCo ty, ty) + refl = (mkNomReflCo ty, ty) ki :: TcKind ki = typeKind ty frr_orig :: FixedRuntimeRepOrigin @@ -634,7 +634,7 @@ makeTypeConcrete conc_orig ty = where go :: TcType -> WriterT [NotConcreteReason] TcM TcType go ty - | Just ty <- tcView ty + | Just ty <- coreView ty = go ty | isConcrete ty = pure ty diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index dec144f5bd..da72eee97a 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -338,7 +338,7 @@ tcLookupInstance cls tys errNotExact = text "Not an exact match (i.e., some variables get instantiated)" uniqueTyVars tys = all isTyVarTy tys - && hasNoDups (map (getTyVar "tcLookupInstance") tys) + && hasNoDups (map getTyVar tys) tcGetInstEnvs :: TcM InstEnvs -- Gets both the external-package inst-env @@ -684,7 +684,7 @@ tcCheckUsage name id_mult thing_inside ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u) ; wrapper <- case actual_u of Bottom -> return idHsWrapper - Zero -> tcSubMult (UsageEnvironmentOf name) Many id_mult + Zero -> tcSubMult (UsageEnvironmentOf name) ManyTy id_mult MUsage m -> do { m <- promote_mult m ; tcSubMult (UsageEnvironmentOf name) m id_mult } ; tcEmitBindingUsage (deleteUE uenv name) diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 6aa02e4788..d5e8e182e9 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -187,7 +187,7 @@ topSkolemise skolem_info ty = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs ; ev_vars1 <- newEvVars (substTheta subst' theta) ; go subst' - (wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1) + (wrap <.> mkWpTyLams tvs1 <.> mkWpEvLams ev_vars1) (tv_prs ++ (map tyVarName tvs `zip` tvs1)) (ev_vars ++ ev_vars1) inner_ty } @@ -203,7 +203,7 @@ topInstantiate ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -- NB: returns a type with no (=>), -- and no invisible forall at the top topInstantiate orig sigma - | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleArgFlag sigma + | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleForAllTyFlag sigma , (theta, body2) <- tcSplitPhiTy body1 , not (null tvs && null theta) = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2 @@ -261,7 +261,7 @@ instTyVarsWith orig tvs tys ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys } where tv_kind = substTy subst (tyVarKind tv) - ty_kind = tcTypeKind ty + ty_kind = typeKind ty go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) @@ -368,6 +368,7 @@ instStupidTheta orig theta -- | Given ty::forall k1 k2. k, instantiate all the invisible forall-binders -- returning ty @kk1 @kk2 :: k[kk1/k1, kk2/k1] +-- Called only to instantiate kinds, in user-written type signatures tcInstInvisibleTyBinders :: TcType -> TcKind -> TcM (TcType, TcKind) tcInstInvisibleTyBinders ty kind = do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind @@ -376,6 +377,7 @@ tcInstInvisibleTyBinders ty kind n_invis = invisibleTyBndrCount kind tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind) +-- Called only to instantiate kinds, in user-written type signatures tcInstInvisibleTyBindersN 0 kind = return ([], kind) tcInstInvisibleTyBindersN n ty @@ -386,27 +388,29 @@ tcInstInvisibleTyBindersN n ty go n subst kind | n > 0 , Just (bndr, body) <- tcSplitPiTy_maybe kind - , isInvisibleBinder bndr + , isInvisiblePiTyBinder bndr = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr ; (args, inner_ty) <- go (n-1) subst' body ; return (arg:args, inner_ty) } | otherwise = return ([], substTy subst kind) --- | Used only in *types* -tcInstInvisibleTyBinder :: Subst -> TyBinder -> TcM (Subst, TcType) +tcInstInvisibleTyBinder :: Subst -> PiTyVarBinder -> TcM (Subst, TcType) +-- Called only to instantiate kinds, in user-written type signatures + tcInstInvisibleTyBinder subst (Named (Bndr tv _)) = do { (subst', tv') <- newMetaTyVarX subst tv ; return (subst', mkTyVarTy tv') } -tcInstInvisibleTyBinder subst (Anon af ty) +tcInstInvisibleTyBinder subst (Anon ty af) | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty)) - -- Equality is the *only* constraint currently handled in types. + -- For kinds like (k1 ~ k2) => blah, we want to emit a unification + -- constraint for (k1 ~# k2) and return the argument (Eq# k1 k2) -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - = assert (af == InvisArg) $ + -- Equality is the *only* constraint currently handled in types. + = assert (isInvisibleFunArg af) $ do { co <- unifyKind Nothing k1 k2 - ; arg' <- mk co - ; return (subst, arg') } + ; return (subst, mk co) } | otherwise -- This should never happen -- See GHC.Core.TyCo.Rep Note [Constraints in kinds] @@ -414,9 +418,9 @@ tcInstInvisibleTyBinder subst (Anon af ty) ------------------------------- get_eq_tys_maybe :: Type - -> Maybe ( Coercion -> TcM Type - -- given a coercion proving t1 ~# t2, produce the - -- right instantiation for the TyBinder at hand + -> Maybe ( Coercion -> Type + -- Given a coercion proving t1 ~# t2, produce the + -- right instantiation for the PiTyVarBinder at hand , Type -- t1 , Type -- t2 ) @@ -425,31 +429,28 @@ get_eq_tys_maybe ty -- Lifted heterogeneous equality (~~) | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty , tc `hasKey` heqTyConKey - = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2) + = Just (mkHEqBoxTy k1 k2, k1, k2) -- Lifted homogeneous equality (~) | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty , tc `hasKey` eqTyConKey - = Just (\co -> mkEqBoxTy co k1 k2, k1, k2) + = Just (mkEqBoxTy k1 k2, k1, k2) | otherwise = Nothing -- | This takes @a ~# b@ and returns @a ~~ b@. -mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type --- monadic just for convenience with mkEqBoxTy -mkHEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] - where k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 +mkHEqBoxTy :: Type -> Type -> TcCoercion -> Type +mkHEqBoxTy ty1 ty2 co + = mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] + where k1 = typeKind ty1 + k2 = typeKind ty2 -- | This takes @a ~# b@ and returns @a ~ b@. -mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type -mkEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] - where k = tcTypeKind ty1 +mkEqBoxTy :: Type -> Type -> TcCoercion -> Type +mkEqBoxTy ty1 ty2 co + = mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] + where k = typeKind ty1 {- ********************************************************************* * * @@ -488,7 +489,7 @@ tcInstTypeBndrs poly_ty subst' = extendSubstInScopeSet subst (tyCoVarsOfType rho) ; return (tv_prs, substTheta subst' theta, substTy subst' tau) } where - (tyvars, rho) = splitForAllInvisTVBinders poly_ty + (tyvars, rho) = tcSplitForAllInvisTVBinders poly_ty (theta, tau) = tcSplitPhiTy rho inst_invis_bndr :: Subst -> InvisTVBinder diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index b2b8c26be4..47599bd94d 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -111,9 +111,9 @@ import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt import GHC.Tc.Types.Origin -import GHC.Tc.Utils.Monad -- TcType, amongst others import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad -- TcType, amongst others import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types import GHC.Tc.Errors.Ppr @@ -191,7 +191,7 @@ newEvVars theta = mapM newEvVar theta newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar -- Creates new *rigid* variables for predicates newEvVar ty = do { name <- newSysName (predTypeOccName ty) - ; return (mkLocalIdOrCoVar name Many ty) } + ; return (mkLocalIdOrCoVar name ManyTy ty) } -- | Create a new Wanted constraint with the given 'CtLoc'. newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence @@ -319,7 +319,7 @@ emitNewExprHole occ ty newDict :: Class -> [TcType] -> TcM DictId newDict cls tys = do { name <- newSysName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name Many (mkClassPred cls tys)) } + ; return (mkLocalId name ManyTy (mkClassPred cls tys)) } predTypeOccName :: PredType -> OccName predTypeOccName ty = case classifyPredType ty of @@ -643,7 +643,7 @@ promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType) promoteTcType dest_lvl ty = do { cur_lvl <- getTcLevel ; if (cur_lvl `sameDepthAs` dest_lvl) - then return (mkTcNomReflCo ty, ty) + then return (mkNomReflCo ty, ty) else promote_it } where promote_it :: TcM (TcCoercion, TcType) @@ -971,13 +971,11 @@ writeMetaTyVarRef tyvar ref ty -- Zonk kinds to allow the error check to work ; zonked_tv_kind <- zonkTcType tv_kind ; zonked_ty <- zonkTcType ty - ; let zonked_ty_kind = tcTypeKind zonked_ty + ; let zonked_ty_kind = typeKind zonked_ty zonked_ty_lvl = tcTypeLevel zonked_ty level_check_ok = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl) level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind - -- Hack alert! eqType, not tcEqType. see: - -- Note [coreView vs tcView] in GHC.Core.Type -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType kind_msg = hang (text "Ill-kinded update to meta tyvar") @@ -1501,24 +1499,24 @@ collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors -> TcM CandidatesQTvs collect_cand_qtvs_co orig_ty bound = go_co where - go_co dv (Refl ty) = collect_cand_qtvs orig_ty True bound dv ty - go_co dv (GRefl _ ty mco) = do dv1 <- collect_cand_qtvs orig_ty True bound dv ty - go_mco dv1 mco - go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos - go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (FunCo _ w co1 co2) = foldlM go_co dv [w, co1, co2] - go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos - go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos - go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov - dv2 <- collect_cand_qtvs orig_ty True bound dv1 t1 - collect_cand_qtvs orig_ty True bound dv2 t2 - go_co dv (SymCo co) = go_co dv co - go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (NthCo _ _ co) = go_co dv co - go_co dv (LRCo _ co) = go_co dv co - go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (KindCo co) = go_co dv co - go_co dv (SubCo co) = go_co dv co + go_co dv (Refl ty) = collect_cand_qtvs orig_ty True bound dv ty + go_co dv (GRefl _ ty mco) = do dv1 <- collect_cand_qtvs orig_ty True bound dv ty + go_mco dv1 mco + go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos + go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (FunCo _ _ _ w co1 co2) = foldlM go_co dv [w, co1, co2] + go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos + go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos + go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov + dv2 <- collect_cand_qtvs orig_ty True bound dv1 t1 + collect_cand_qtvs orig_ty True bound dv2 t2 + go_co dv (SymCo co) = go_co dv co + go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (SelCo _ co) = go_co dv co + go_co dv (LRCo _ co) = go_co dv co + go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (KindCo co) = go_co dv co + go_co dv (SubCo co) = go_co dv co go_co dv (HoleCo hole) = do m_co <- unpackCoercionHole_maybe hole @@ -2520,7 +2518,7 @@ zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar zonkTcTyVarToTcTyVar tv = do { ty <- zonkTcTyVar tv - ; let tv' = case tcGetTyVar_maybe ty of + ; let tv' = case getTyVar_maybe ty of Just tv' -> tv' Nothing -> pprPanic "zonkTcTyVarToTcTyVar" (ppr tv $$ ppr ty) diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index c0f42e056f..5c1e13ab76 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -36,10 +36,12 @@ module GHC.Tc.Utils.TcType ( SyntaxOpType(..), synKnownType, mkSynFunTys, + -------------------------------- -- TcLevel TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, strictlyDeeperThan, deeperThanOrSame, sameDepthAs, tcTypeLevel, tcTyVarLevel, maxTcLevel, + -------------------------------- -- MetaDetails TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTvUnk, @@ -56,13 +58,12 @@ module GHC.Tc.Utils.TcType ( -------------------------------- -- Builders - mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, - mkTcAppTy, mkTcAppTys, mkTcCastTy, + mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, mkPhiTy, tcMkPhiTy, + tcMkDFunSigmaTy, tcMkDFunPhiTy, -------------------------------- -- Splitters - -- These are important because they do not look through newtypes - getTyVar, + getTyVar, getTyVar_maybe, getCastedTyVar_maybe, tcSplitForAllTyVarBinder_maybe, tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars, tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders, @@ -72,26 +73,27 @@ module GHC.Tc.Utils.TcType ( tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, - tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, - tcRepGetNumAppTys, - tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe, tcSplitSigmaTy, tcSplitNestedSigmaTys, --------------------------------- -- Predicates. -- Again, newtypes are opaque - eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, - tcEqTyConApps, isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isNaturalTy, isBoolTy, isUnitTy, isCharTy, - isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, + isTauTy, isTauTyCon, tcIsTyVarTy, isPredTy, isTyVarClassPred, checkValidClsArgs, hasTyVarHead, isRigidTy, + -- Re-exported from GHC.Core.TyCo.Compare + -- mainly just for back-compat reasons + eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + tcEqTyConApps, eqForAllVis, eqVarBndrs, + --------------------------------- -- Misc type manipulators @@ -132,21 +134,20 @@ module GHC.Tc.Utils.TcType ( -------------------------------- -- Reexported from Kind - Kind, tcTypeKind, - liftedTypeKind, - constraintKind, - isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, + Kind, liftedTypeKind, constraintKind, + isLiftedTypeKind, isUnliftedTypeKind, isTYPEorCONSTRAINT, -------------------------------- -- Reexported from Type - Type, PredType, ThetaType, TyCoBinder, - ArgFlag(..), AnonArgFlag(..), + Type, PredType, ThetaType, PiTyBinder, + ForAllTyFlag(..), FunTyFlag(..), mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy, mkInfForAllTy, mkInfForAllTys, - mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTyMany, - mkVisFunTyMany, mkVisFunTysMany, mkInvisFunTysMany, + mkVisFunTy, mkVisFunTyMany, mkVisFunTysMany, + mkScaledFunTys, + mkInvisFunTy, mkInvisFunTys, mkTyConApp, mkAppTy, mkAppTys, mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, @@ -155,7 +156,7 @@ module GHC.Tc.Utils.TcType ( mkClassPred, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, isRuntimeRepVar, isFixedRuntimeRepKind, - isVisibleBinder, isInvisibleBinder, + isVisiblePiTyBinder, isInvisiblePiTyBinder, -- Type substitutions Subst(..), -- Representation visible to a few friends @@ -179,7 +180,7 @@ module GHC.Tc.Utils.TcType ( isUnboxedTupleType, isPrimitiveType, - tcView, coreView, + coreView, tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, tyCoFVsOfType, tyCoFVsOfTypes, @@ -206,6 +207,7 @@ import GHC.Prelude import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) +import GHC.Core.TyCo.Compare import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr import GHC.Core.Class @@ -229,7 +231,6 @@ import GHC.Types.Name as Name -- We use this to make dictionaries for type literals. -- Perhaps there's a better way to do this? import GHC.Types.Name.Set -import GHC.Types.Var.Env import GHC.Builtin.Names import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey , listTyCon, constraintKind ) @@ -883,7 +884,7 @@ tcTyFamInstsAndVisX tcTyFamInstsAndVisX = go where go is_invis_arg ty - | Just exp_ty <- tcView ty = go is_invis_arg exp_ty + | Just exp_ty <- coreView ty = go is_invis_arg exp_ty go _ (TyVarTy _) = [] go is_invis_arg (TyConApp tc tys) | isTypeFamilyTyCon tc @@ -898,9 +899,9 @@ tcTyFamInstsAndVisX = go ++ go is_invis_arg ty2 go is_invis_arg ty@(AppTy _ _) = let (ty_head, ty_args) = splitAppTys ty - ty_arg_flags = appTyArgFlags ty_head ty_args + ty_arg_flags = appTyForAllTyFlags ty_head ty_args in go is_invis_arg ty_head - ++ concat (zipWith (\flag -> go (isInvisibleArgFlag flag)) + ++ concat (zipWith (\flag -> go (isInvisibleForAllTyFlag flag)) ty_arg_flags ty_args) go is_invis_arg (CastTy ty _) = go is_invis_arg ty go _ (CoercionTy _) = [] -- don't count tyfams in coercions, @@ -954,7 +955,7 @@ any_rewritable role tv_pred tc_pred should_expand go rl bvs ty@(TyConApp tc tys) | isTypeSynonymTyCon tc , should_expand tc - , Just ty' <- tcView ty -- should always match + , Just ty' <- coreView ty -- should always match = go rl bvs ty' | tc_pred rl tc tys @@ -1043,7 +1044,7 @@ which type variables are mentioned in a type. It only matters occasionally -- see the calls to exactTyCoVarsOfType. We place this function here in GHC.Tc.Utils.TcType, not in GHC.Core.TyCo.FVs, -because we want to "see" tcView (efficiency issue only). +because we want to "see" coreView (efficiency issue only). -} exactTyCoVarsOfType :: Type -> TyCoVarSet @@ -1059,7 +1060,7 @@ exact_tys :: [Type] -> Endo TyCoVarSet (exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) -exactTcvFolder = deepTcvFolder { tcf_view = tcView } +exactTcvFolder = deepTcvFolder { tcf_view = coreView } -- This is the key line {- @@ -1280,21 +1281,38 @@ ambigTkvsOfTy ty ************************************************************************ -} -mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type -mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) - -- | Make a sigma ty where all type variables are 'Inferred'. That is, -- they cannot be used with visible type application. -mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type -mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty +mkInfSigmaTy :: HasDebugCallStack => [TyCoVar] -> [PredType] -> Type -> Type +mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkForAllTyBinders Inferred tyvars) theta ty -- | Make a sigma ty where all type variables are "specified". That is, -- they can be used with visible type application -mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty +mkSpecSigmaTy :: HasDebugCallStack => [TyVar] -> [PredType] -> Type -> Type +mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkForAllTyBinders Specified tyvars) preds ty + +mkSigmaTy :: HasDebugCallStack => [ForAllTyBinder] -> [PredType] -> Type -> Type +-- Result is TypeLike +mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) + +tcMkDFunSigmaTy :: [TyVar] -> ThetaType -> Type -> Type +tcMkDFunSigmaTy tvs theta res_ty + = mkForAllTys (mkForAllTyBinders Specified tvs) $ + tcMkDFunPhiTy theta res_ty -mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy = mkInvisFunTysMany +mkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type +-- Result type is TypeLike +mkPhiTy = mkInvisFunTys + +tcMkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type +-- Like mkPhiTy, but with no assertion checks; it is called +-- by the type checker and the result kind may not be zonked yet +-- But the result kind is TypeLike +tcMkPhiTy tys ty = foldr (tcMkInvisFunTy TypeLike) ty tys + +tcMkDFunPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type +-- Just like tcMkPhiTy, but result type is ConstraintLike +tcMkDFunPhiTy preds res = foldr (tcMkInvisFunTy ConstraintLike) res preds --------------- getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to @@ -1304,7 +1322,7 @@ getDFunTyKey (TyVarTy tv) = getOccName tv getDFunTyKey (TyConApp tc _) = getOccName tc getDFunTyKey (LitTy x) = getDFunTyLitKey x getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (FunTy {}) = getOccName funTyCon +getDFunTyKey (FunTy { ft_af = af }) = getOccName (funTyFlagTyCon af) getDFunTyKey (ForAllTy _ t) = getDFunTyKey t getDFunTyKey (CastTy ty _) = getDFunTyKey ty getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) @@ -1314,58 +1332,34 @@ getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm getDFunTyLitKey (CharTyLit n) = mkOccName Name.varName (show n) -{- ********************************************************************* -* * - Building types -* * -********************************************************************* -} - --- ToDo: I think we need Tc versions of these --- Reason: mkCastTy checks isReflexiveCastTy, which checks --- for equality; and that has a different answer --- depending on whether or not Type = Constraint - -mkTcAppTys :: Type -> [Type] -> Type -mkTcAppTys = mkAppTys - -mkTcAppTy :: Type -> Type -> Type -mkTcAppTy = mkAppTy - -mkTcCastTy :: Type -> Coercion -> Type -mkTcCastTy = mkCastTy -- Do we need a tc version of mkCastTy? - {- ************************************************************************ * * Expanding and splitting * * ************************************************************************ - -These tcSplit functions are like their non-Tc analogues, but - *) they do not look through newtypes - -However, they are non-monadic and do not follow through mutable type -variables. It's up to you to make sure this doesn't matter. -} --- | Splits a forall type into a list of 'TyBinder's and the inner type. +-- | Splits a forall type into a list of 'PiTyVarBinder's and the inner type. -- Always succeeds, even if it returns an empty list. -tcSplitPiTys :: Type -> ([TyBinder], Type) +tcSplitPiTys :: Type -> ([PiTyVarBinder], Type) tcSplitPiTys ty - = assert (all isTyBinder (fst sty) ) sty + = assert (all isTyBinder (fst sty) ) -- No CoVar binders here + sty where sty = splitPiTys ty --- | Splits a type into a TyBinder and a body, if possible. Panics otherwise -tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) +-- | Splits a type into a PiTyVarBinder and a body, if possible. +tcSplitPiTy_maybe :: Type -> Maybe (PiTyVarBinder, Type) tcSplitPiTy_maybe ty - = assert (isMaybeTyBinder sty ) sty + = assert (isMaybeTyBinder sty) -- No CoVar binders here + sty where sty = splitPiTy_maybe ty isMaybeTyBinder (Just (t,_)) = isTyBinder t isMaybeTyBinder _ = True tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type) -tcSplitForAllTyVarBinder_maybe ty | Just ty' <- tcView ty = tcSplitForAllTyVarBinder_maybe ty' +tcSplitForAllTyVarBinder_maybe ty | Just ty' <- coreView ty = tcSplitForAllTyVarBinder_maybe ty' tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = assert (isTyVarBinder tv ) Just (tv, ty) tcSplitForAllTyVarBinder_maybe _ = Nothing @@ -1379,13 +1373,13 @@ tcSplitForAllTyVars ty -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' -- type variable binders. tcSplitForAllInvisTyVars :: Type -> ([TyVar], Type) -tcSplitForAllInvisTyVars ty = tcSplitSomeForAllTyVars isInvisibleArgFlag ty +tcSplitForAllInvisTyVars ty = tcSplitSomeForAllTyVars isInvisibleForAllTyFlag ty -- | Like 'tcSplitForAllTyVars', but only splits a 'ForAllTy' if @argf_pred argf@ -- is 'True', where @argf@ is the visibility of the @ForAllTy@'s binder and -- @argf_pred@ is a predicate over visibilities provided as an argument to this -- function. -tcSplitSomeForAllTyVars :: (ArgFlag -> Bool) -> Type -> ([TyVar], Type) +tcSplitSomeForAllTyVars :: (ForAllTyFlag -> Bool) -> Type -> ([TyVar], Type) tcSplitSomeForAllTyVars argf_pred ty = split ty ty [] where @@ -1397,32 +1391,26 @@ tcSplitSomeForAllTyVars argf_pred ty -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. All split tyvars are annotated with '()'. tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type) -tcSplitForAllReqTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty - where sty = splitForAllReqTVBinders ty +tcSplitForAllReqTVBinders ty = assert (all isTyVarBinder (fst sty) ) sty + where sty = splitForAllReqTyBinders ty -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' type -- variable binders. All split tyvars are annotated with their 'Specificity'. tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type) -tcSplitForAllInvisTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty - where sty = splitForAllInvisTVBinders ty +tcSplitForAllInvisTVBinders ty = assert (all (isTyVar . binderVar) (fst sty)) sty + where sty = splitForAllInvisTyBinders ty -- | Like 'tcSplitForAllTyVars', but splits off only named binders. tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type) tcSplitForAllTyVarBinders ty = assert (all isTyVarBinder (fst sty)) sty - where sty = splitForAllTyCoVarBinders ty - --- | Is this a ForAllTy with a named binder? -tcIsForAllTy :: Type -> Bool -tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy {}) = True -tcIsForAllTy _ = False + where sty = splitForAllForAllTyBinders ty tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) -- Split off the first predicate argument from a type tcSplitPredFunTy_maybe ty - | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' -tcSplitPredFunTy_maybe (FunTy { ft_af = InvisArg - , ft_arg = arg, ft_res = res }) + | Just ty' <- coreView ty = tcSplitPredFunTy_maybe ty' +tcSplitPredFunTy_maybe (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + | isInvisibleFunArg af = Just (arg, res) tcSplitPredFunTy_maybe _ = Nothing @@ -1457,7 +1445,7 @@ tcSplitNestedSigmaTys ty , (tvs1, theta1, rho1) <- tcSplitSigmaTy body_ty , not (null tvs1 && null theta1) = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 - in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2) + in (tvs1 ++ tvs2, theta1 ++ theta2, mkScaledFunTys arg_tys rho2) -- If there's no forall, we're done. | otherwise = ([], [], ty) @@ -1498,26 +1486,16 @@ tcTyConAppTyCon ty -- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'. tcTyConAppTyCon_maybe :: Type -> Maybe TyCon -tcTyConAppTyCon_maybe ty - | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty' -tcTyConAppTyCon_maybe (TyConApp tc _) - = Just tc -tcTyConAppTyCon_maybe (FunTy { ft_af = VisArg }) - = Just funTyCon -- (=>) is /not/ a TyCon in its own right - -- C.f. tcRepSplitAppTy_maybe -tcTyConAppTyCon_maybe _ - = Nothing +tcTyConAppTyCon_maybe ty | Just ty' <- coreView ty = tcTyConAppTyCon_maybe ty' +tcTyConAppTyCon_maybe (TyConApp tc _) = Just tc +tcTyConAppTyCon_maybe (FunTy { ft_af = af }) = Just (funTyFlagTyCon af) +tcTyConAppTyCon_maybe _ = Nothing tcTyConAppArgs :: Type -> [Type] tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of Just (_, args) -> args Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) -tcSplitTyConApp :: Type -> (TyCon, [Type]) -tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) - ----------------------- tcSplitFunTys :: Type -> ([Scaled Type], Type) tcSplitFunTys ty = case tcSplitFunTy_maybe ty of @@ -1527,12 +1505,13 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of (args,res') = tcSplitFunTys res tcSplitFunTy_maybe :: Type -> Maybe (Scaled Type, Type) +-- Only splits function (->) and (-=>), not (=>) or (==>) tcSplitFunTy_maybe ty - | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' + | Just ty' <- coreView ty = tcSplitFunTy_maybe ty' tcSplitFunTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) - | VisArg <- af = Just (Scaled w arg, res) -tcSplitFunTy_maybe _ = Nothing - -- Note the VisArg guard + | isVisibleFunArg af = Just (Scaled w arg, res) +tcSplitFunTy_maybe _ = Nothing + -- Note the isVisibleFunArg guard -- Consider (?x::Int) => Bool -- We don't want to treat this as a function type! -- A concrete example is test tc230: @@ -1563,7 +1542,7 @@ tcSplitFunTy :: Type -> (Scaled Type, Type) tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) tcFunArgTy :: Type -> Scaled Type -tcFunArgTy ty = fst (tcSplitFunTy ty) +tcFunArgTy ty = fst (tcSplitFunTy ty) tcFunResultTy :: Type -> Type tcFunResultTy ty = snd (tcSplitFunTy ty) @@ -1578,8 +1557,8 @@ tcFunResultTyN n ty ----------------------- tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' -tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty +tcSplitAppTy_maybe ty | Just ty' <- coreView ty = tcSplitAppTy_maybe ty' +tcSplitAppTy_maybe ty = tcSplitAppTyNoView_maybe ty tcSplitAppTy :: Type -> (Type, Type) tcSplitAppTy ty = case tcSplitAppTy_maybe ty of @@ -1594,34 +1573,9 @@ tcSplitAppTys ty Just (ty', arg) -> go ty' (arg:args) Nothing -> (ty,args) --- | Returns the number of arguments in the given type, without --- looking through synonyms. This is used only for error reporting. --- We don't look through synonyms because of #11313. -tcRepGetNumAppTys :: Type -> Arity -tcRepGetNumAppTys = length . snd . repSplitAppTys - ----------------------- --- | If the type is a tyvar, possibly under a cast, returns it, along --- with the coercion. Thus, the co is :: kind tv ~N kind type -tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) -tcGetCastedTyVar_maybe ty | Just ty' <- tcView ty = tcGetCastedTyVar_maybe ty' -tcGetCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) -tcGetCastedTyVar_maybe (TyVarTy tv) = Just (tv, mkNomReflCo (tyVarKind tv)) -tcGetCastedTyVar_maybe _ = Nothing - -tcGetTyVar_maybe :: Type -> Maybe TyVar -tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' -tcGetTyVar_maybe (TyVarTy tv) = Just tv -tcGetTyVar_maybe _ = Nothing - -tcGetTyVar :: String -> Type -> TyVar -tcGetTyVar msg ty - = case tcGetTyVar_maybe ty of - Just tv -> tv - Nothing -> pprPanic msg (ppr ty) - tcIsTyVarTy :: Type -> Bool -tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty' +tcIsTyVarTy ty | Just ty' <- coreView ty = tcIsTyVarTy ty' tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as -- this is only used for -- e.g., FlexibleContexts @@ -1668,178 +1622,6 @@ tcSplitMethodTy ty {- ********************************************************************* * * - Type equalities -* * -********************************************************************* -} - -tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool -tcEqKind = tcEqType - -tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool --- ^ tcEqType implements typechecker equality, as described in --- @Note [Typechecker equality vs definitional equality]@. -tcEqType ty1 ty2 - = tcEqTypeNoSyns ki1 ki2 - && tcEqTypeNoSyns ty1 ty2 - where - ki1 = tcTypeKind ty1 - ki2 = tcTypeKind ty2 - --- | Just like 'tcEqType', but will return True for types of different kinds --- as long as their non-coercion structure is identical. -tcEqTypeNoKindCheck :: TcType -> TcType -> Bool -tcEqTypeNoKindCheck ty1 ty2 - = tcEqTypeNoSyns ty1 ty2 - --- | Check whether two TyConApps are the same; if the number of arguments --- are different, just checks the common prefix of arguments. -tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool -tcEqTyConApps tc1 args1 tc2 args2 - = tc1 == tc2 && - and (zipWith tcEqTypeNoKindCheck args1 args2) - -- No kind check necessary: if both arguments are well typed, then - -- any difference in the kinds of later arguments would show up - -- as differences in earlier (dependent) arguments - -{- -Note [Specialising tc_eq_type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type equality predicates in TcType are hit pretty hard during typechecking. -Consequently we take pains to ensure that these paths are compiled to -efficient, minimally-allocating code. - -To this end we place an INLINE on tc_eq_type, ensuring that it is inlined into -its publicly-visible interfaces (e.g. tcEqType). In addition to eliminating -some dynamic branches, this allows the simplifier to eliminate the closure -allocations that would otherwise be necessary to capture the two boolean "mode" -flags. This reduces allocations by a good fraction of a percent when compiling -Cabal. - -See #19226. --} - --- | Type equality comparing both visible and invisible arguments and expanding --- type synonyms. -tcEqTypeNoSyns :: TcType -> TcType -> Bool -tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb - --- | Like 'tcEqType', but returns True if the /visible/ part of the types --- are equal, even if they are really unequal (in the invisible bits) -tcEqTypeVis :: TcType -> TcType -> Bool -tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 - --- | Like 'pickyEqTypeVis', but returns a Bool for convenience -pickyEqType :: TcType -> TcType -> Bool --- Check when two types _look_ the same, _including_ synonyms. --- So (pickyEqType String [Char]) returns False --- This ignores kinds and coercions, because this is used only for printing. -pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 - --- | Real worker for 'tcEqType'. No kind check! -tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms - -> Bool -- ^ True <=> compare visible args only - -> Type -> Type - -> Bool --- Flags False, False is the usual setting for tc_eq_type --- See Note [Computing equality on types] in Type -tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 - = go orig_env orig_ty1 orig_ty2 - where - go :: RnEnv2 -> Type -> Type -> Bool - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. - go _ (TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = True - - go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2 - go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2' - - go env (TyVarTy tv1) (TyVarTy tv2) - = rnOccL env tv1 == rnOccR env tv2 - - go _ (LitTy lit1) (LitTy lit2) - = lit1 == lit2 - - go env (ForAllTy (Bndr tv1 vis1) ty1) - (ForAllTy (Bndr tv2 vis2) ty2) - = vis1 `sameVis` vis2 - -- See Note [ForAllTy and typechecker equality] in - -- GHC.Tc.Solver.Canonical for why we use `sameVis` here - && (vis_only || go env (varType tv1) (varType tv2)) - && go (rnBndr2 env tv1 tv2) ty1 ty2 - - -- Make sure we handle all FunTy cases since falling through to the - -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked - -- kind variable, which causes things to blow up. - -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check - -- kinds here - go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) - = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2 - where - kinds_eq | vis_only = True - | otherwise = go env (typeKind arg1) (typeKind arg2) && - go env (typeKind res1) (typeKind res2) - - -- See Note [Equality on AppTys] in GHC.Core.Type - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 - = go env s1 s2 && go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1 - = go env s1 s2 && go env t1 t2 - - go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) - = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 - - go env (CastTy t1 _) t2 = go env t1 t2 - go env t1 (CastTy t2 _) = go env t1 t2 - go _ (CoercionTy {}) (CoercionTy {}) = True - - go _ _ _ = False - - gos _ _ [] [] = True - gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) - && gos env igs ts1 ts2 - gos _ _ _ _ = False - - tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore - tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles - | otherwise = repeat False -- Ignore nothing - -- The repeat False is necessary because tycons - -- can legitimately be oversaturated - where - bndrs = tyConBinders tc - inviss = map isInvisibleTyConBinder bndrs - - orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - -{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. - -{- Note [Typechecker equality vs definitional equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has two notions of equality over Core types: - -* Definitional equality, as implemented by GHC.Core.Type.eqType. - See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. -* Typechecker equality, as implemented by tcEqType (in GHC.Tc.Utils.TcType). - GHC.Tc.Solver.Canonical.canEqNC also respects typechecker equality. - -Typechecker equality implies definitional equality: if two types are equal -according to typechecker equality, then they are also equal according to -definitional equality. The converse is not always true, as typechecker equality -is more finer-grained than definitional equality in two places: - -* Unlike definitional equality, which equates Type and Constraint, typechecker - treats them as distinct types. See Note [Kind Constraint and kind Type] in - GHC.Core.Type. -* Unlike definitional equality, which does not care about the ArgFlag of a - ForAllTy, typechecker equality treats Required type variable binders as - distinct from Invisible type variable binders. - See Note [ForAllTy and typechecker equality] in GHC.Tc.Solver.Canonical. --} - -{- ********************************************************************* -* * Predicate types * * ************************************************************************ @@ -1905,8 +1687,8 @@ boxEqPred eq_rel ty1 ty2 -- so we can't abstract over it -- Nothing fundamental: we could add it where - k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 + k1 = typeKind ty1 + k2 = typeKind ty2 homo_kind = k1 `tcEqType` k2 pickCapturedPreds @@ -2077,15 +1859,15 @@ isSigmaTy :: TcType -> Bool -- isSigmaTy returns true of any qualified type. It doesn't -- *necessarily* have any foralls. E.g -- f :: (?x::Int) => Int -> Int -isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' +isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty' isSigmaTy (ForAllTy {}) = True -isSigmaTy (FunTy { ft_af = InvisArg }) = True +isSigmaTy (FunTy { ft_af = af }) = isInvisibleFunArg af isSigmaTy _ = False isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] -isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty' +isRhoTy ty | Just ty' <- coreView ty = isRhoTy ty' isRhoTy (ForAllTy {}) = False -isRhoTy (FunTy { ft_af = InvisArg }) = False +isRhoTy (FunTy { ft_af = af }) = isVisibleFunArg af isRhoTy _ = True -- | Like 'isRhoTy', but also says 'True' for 'Infer' types @@ -2096,9 +1878,9 @@ isRhoExpTy (Infer {}) = True isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing -- Used only by bindLocalMethods -isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' +isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty -isOverloadedTy (FunTy { ft_af = InvisArg }) = True +isOverloadedTy (FunTy { ft_af = af }) = isInvisibleFunArg af isOverloadedTy _ = False isFloatTy, isDoubleTy, @@ -2196,7 +1978,7 @@ Note that the a is in braces, meaning it cannot be instantiated with visible type application. Tracking specified vs. inferred variables is done conveniently by a field -in TyBinder. +in PiTyVarBinder. -} @@ -2522,8 +2304,8 @@ sizeType :: Type -> TypeSize -- Ignore kinds altogether sizeType = go where - go ty | Just exp_ty <- tcView ty = go exp_ty - go (TyVarTy {}) = 1 + go ty | Just exp_ty <- coreView ty = go exp_ty + go (TyVarTy {}) = 1 go (TyConApp tc tys) | isTypeFamilyTyCon tc = infinity -- Type-family applications can -- expand to any arbitrary size @@ -2535,10 +2317,10 @@ sizeType = go go (FunTy _ w arg res) = go w + go arg + go res + 1 go (AppTy fun arg) = go fun + go arg go (ForAllTy (Bndr tv vis) ty) - | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 - | otherwise = go ty + 1 - go (CastTy ty _) = go ty - go (CoercionTy {}) = 0 + | isVisibleForAllTyFlag vis = go (tyVarKind tv) + go ty + 1 + | otherwise = go ty + 1 + go (CastTy ty _) = go ty + go (CoercionTy {}) = 0 sizeTypes :: [Type] -> TypeSize sizeTypes tys = sum (map sizeType tys) @@ -2553,7 +2335,7 @@ tcTyConVisibilities :: TyCon -> [Bool] tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True where tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc) - tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc)) + tc_return_kind_viss = map isVisiblePiTyBinder (fst $ tcSplitPiTys (tyConResKind tc)) -- | If the tycon is applied to the types, is the next argument visible? isNextTyConArgVisible :: TyCon -> [Type] -> Bool @@ -2563,7 +2345,7 @@ isNextTyConArgVisible tc tys -- | Should this type be applied to a visible argument? isNextArgVisible :: TcType -> Bool isNextArgVisible ty - | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr + | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisiblePiTyBinder bndr | otherwise = True -- this second case might happen if, say, we have an unzonked TauTv. -- But TauTvs can't range over types that take invisible arguments diff --git a/compiler/GHC/Tc/Utils/TcType.hs-boot b/compiler/GHC/Tc/Utils/TcType.hs-boot index 4d09c1e7e1..e7b159bf59 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs-boot +++ b/compiler/GHC/Tc/Utils/TcType.hs-boot @@ -2,8 +2,6 @@ module GHC.Tc.Utils.TcType where import GHC.Utils.Outputable( SDoc ) import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar ) -import {-# SOURCE #-} GHC.Core.TyCo.Rep -import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Stack data MetaDetails @@ -15,5 +13,3 @@ isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool isConcreteTyVar :: TcTyVar -> Bool -tcEqType :: HasDebugCallStack => Type -> Type -> Bool - diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index d013753bae..61787d299f 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -42,8 +42,7 @@ module GHC.Tc.Utils.Unify ( import GHC.Prelude import GHC.Hs -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr( debugPprType ) + import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, makeTypeConcrete, hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Instantiate @@ -52,6 +51,9 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr( debugPprType ) +import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Multiplicity @@ -62,7 +64,6 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin import GHC.Types.Name( Name, isSystemName ) -import GHC.Core.TyCon import GHC.Builtin.Types import GHC.Types.Var as Var import GHC.Types.Var.Set @@ -132,10 +133,10 @@ matchActualFunTySigma herald mb_thing err_info fun_ty go :: TcRhoType -- The type we're processing, perhaps after -- expanding type synonyms -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) - go ty | Just ty' <- tcView ty = go ty' + go ty | Just ty' <- coreView ty = go ty' go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) - = assert (af == VisArg) $ + = assert (isVisibleFunArg af) $ do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty ; return (idHsWrapper, Scaled w arg_ty, res_ty) } @@ -168,7 +169,7 @@ matchActualFunTySigma herald mb_thing err_info fun_ty = do { arg_ty <- newOpenFlexiTyVarTy ; res_ty <- newOpenFlexiTyVarTy ; mult <- newFlexiTyVarTy multiplicityTy - ; let unif_fun_ty = mkVisFunTy mult arg_ty res_ty + ; let unif_fun_ty = tcMkVisFunTy mult arg_ty res_ty ; co <- unifyType mb_thing fun_ty unif_fun_ty ; hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) } @@ -387,17 +388,17 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside go acc_arg_tys n ty' ; return (wrap_gen <.> wrap_res, result) } - -- No more args; do this /before/ tcView, so + -- No more args; do this /before/ coreView, so -- that we do not unnecessarily unwrap synonyms go acc_arg_tys 0 rho_ty = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty) ; return (idHsWrapper, result) } go acc_arg_tys n ty - | Just ty' <- tcView ty = go acc_arg_tys n ty' + | Just ty' <- coreView ty = go acc_arg_tys n ty' - go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) - = assert (af == VisArg) $ + go acc_arg_tys n (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg_ty, ft_res = res_ty }) + = assert (isVisibleFunArg af) $ do { let arg_pos = 1 + length acc_arg_tys -- for error messages only ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty ; (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) @@ -440,7 +441,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys ; res_ty <- readExpType res_ty - ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty + ; let unif_fun_ty = mkScaledFunTys more_arg_tys res_ty ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty -- Not a good origin at all :-( ; return (wrap, result) } @@ -465,7 +466,7 @@ mkFunTysMsg :: TidyEnv -> TcM (TidyEnv, SDoc) mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call = do { (env', fun_rho) <- zonkTidyTcType env $ - mkVisFunTys arg_tys res_ty + mkScaledFunTys arg_tys res_ty ; let (all_arg_tys, _) = splitFunTys fun_rho n_fun_args = length all_arg_tys @@ -502,15 +503,16 @@ matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> -- Postcondition: (T k1 k2 k3 a b c) is well-kinded matchExpectedTyConApp tc orig_ty - = assert (not $ isFunTyCon tc) $ go orig_ty + = assertPpr (isAlgTyCon tc) (ppr tc) $ + go orig_ty where go ty - | Just ty' <- tcView ty + | Just ty' <- coreView ty = go ty' go ty@(TyConApp tycon args) | tc == tycon -- Common case - = return (mkTcNomReflCo ty, args) + = return (mkNomReflCo ty, args) go (TyVarTy tv) | isMetaTyVar tv @@ -550,10 +552,10 @@ matchExpectedAppTy orig_ty = go orig_ty where go ty - | Just ty' <- tcView ty = go ty' + | Just ty' <- coreView ty = go ty' | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty)) + = return (mkNomReflCo orig_ty, (fun_ty, arg_ty)) go (TyVarTy tv) | isMetaTyVar tv @@ -571,7 +573,7 @@ matchExpectedAppTy orig_ty ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty ; return (co, (ty1, ty2)) } - orig_kind = tcTypeKind orig_ty + orig_kind = typeKind orig_ty kind1 = mkVisFunTyMany liftedTypeKind orig_kind kind2 = liftedTypeKind -- m :: * -> k -- arg type :: * @@ -651,7 +653,7 @@ fillInferResult act_res_ty (IR { ir_uniq = u Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty -- Compose the two coercions. - ; let final_co = prom_co `mkTcTransCo` frr_co + ; let final_co = prom_co `mkTransCo` frr_co ; writeTcRef ref (Just act_res_ty) @@ -840,7 +842,7 @@ tcSubTypePat _ _ (Infer inf_res) ty_expected = do { co <- fillInferResult ty_expected inf_res -- In patterns we do not instantatiate - ; return (mkWpCastN (mkTcSymCo co)) } + ; return (mkWpCastN (mkSymCo co)) } --------------- tcSubType :: CtOrigin -> UserTypeCtxt @@ -1278,9 +1280,9 @@ tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected , text "ty_expected =" <+> ppr ty_expected ] ; go ty_actual ty_expected } where - -- NB: 'go' is not recursive, except for doing tcView - go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e - | Just ty_e' <- tcView ty_e = go ty_a ty_e' + -- NB: 'go' is not recursive, except for doing coreView + go ty_a ty_e | Just ty_a' <- coreView ty_a = go ty_a' ty_e + | Just ty_e' <- coreView ty_e = go ty_a ty_e' go (TyVarTy tv_a) ty_e = do { lookup_res <- isFilledMetaTyVar_maybe tv_a @@ -1291,13 +1293,13 @@ tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected ; tc_sub_type_ds unify inst_orig ctxt ty_a' ty_e } Nothing -> just_unify ty_actual ty_expected } - go ty_a@(FunTy { ft_af = VisArg, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) - ty_e@(FunTy { ft_af = VisArg, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) - | isTauTy ty_a, isTauTy ty_e -- Short cut common case to avoid - = just_unify ty_actual ty_expected -- unnecessary eta expansion - - | otherwise - = -- This is where we do the co/contra thing, and generate a WpFun, which in turn + go ty_a@(FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) + ty_e@(FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) + | isVisibleFunArg af1, isVisibleFunArg af2 + = if (isTauTy ty_a && isTauTy ty_e) -- Short cut common case to avoid + then just_unify ty_actual ty_expected -- unnecessary eta expansion + else + -- This is where we do the co/contra thing, and generate a WpFun, which in turn -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption do { arg_wrap <- tc_sub_type_deep unify given_orig GenSigCtxt exp_arg act_arg -- GenSigCtxt: See Note [Setting the argument context] @@ -1380,14 +1382,12 @@ deeplySkolemise skol_info ty ; ev_vars1 <- newEvVars (substTheta subst' theta) ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' ; let tv_prs1 = map tyVarName tvs `zip` tvs1 - ; return ( mkWpLams ids1 - <.> mkWpTyLams tvs1 - <.> mkWpLams ev_vars1 - <.> wrap - <.> mkWpEvVarApps ids1 + ; return ( mkWpEta ids1 (mkWpTyLams tvs1 + <.> mkWpEvLams ev_vars1 + <.> wrap) , tv_prs1 ++ tvs_prs2 , ev_vars1 ++ ev_vars2 - , mkVisFunTys arg_tys' rho ) } + , mkScaledFunTys arg_tys' rho ) } | otherwise = return (idHsWrapper, [], [], substTy subst ty) @@ -1407,11 +1407,8 @@ deeplyInstantiate orig ty ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' ; (wrap2, rho2) <- go subst' rho - ; return (mkWpLams ids1 - <.> wrap2 - <.> wrap1 - <.> mkWpEvVarApps ids1, - mkVisFunTys arg_tys' rho2) } + ; return (mkWpEta ids1 (wrap2 <.> wrap1), + mkScaledFunTys arg_tys' rho2) } | otherwise = do { let ty' = substTy subst ty @@ -1703,7 +1700,7 @@ non-exported generic functions. -} unifyType :: Maybe TypedThing -- ^ If present, the thing that has type ty1 - -> TcTauType -> TcTauType -- ty1, ty2 + -> TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) -> TcM TcCoercionN -- :: ty1 ~# ty2 -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 @@ -1757,6 +1754,8 @@ uType, uType_defer -------------- -- It is always safe to defer unification to the main constraint solver -- See Note [Deferred unification] +-- ty1 is "actual" +-- ty2 is "expected" uType_defer t_or_k origin ty1 ty2 = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2 @@ -1833,17 +1832,18 @@ uType t_or_k origin orig_ty1 orig_ty2 -- we'll end up saying "can't match Foo with Bool" -- rather than "can't match "Int with Bool". See #4535. go ty1 ty2 - | Just ty1' <- tcView ty1 = go ty1' ty2 - | Just ty2' <- tcView ty2 = go ty1 ty2' + | Just ty1' <- coreView ty1 = go ty1' ty2 + | Just ty2' <- coreView ty2 = go ty1 ty2' -- Functions (t1 -> t2) just check the two parts -- Do not attempt (c => t); just defer - go (FunTy { ft_af = VisArg, ft_mult = w1, ft_arg = arg1, ft_res = res1 }) - (FunTy { ft_af = VisArg, ft_mult = w2, ft_arg = arg2, ft_res = 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 }) + | isVisibleFunArg af1, af1 == af2 = do { co_l <- uType t_or_k origin arg1 arg2 ; co_r <- uType t_or_k origin res1 res2 ; co_w <- uType t_or_k origin w1 w2 - ; return $ mkFunCo Nominal co_w co_l co_r } + ; return $ mkNakedFunCo1 Nominal af1 co_w co_l co_r } -- Always defer if a type synonym family (type function) -- is involved. (Data families behave rigidly.) @@ -1874,12 +1874,12 @@ uType t_or_k origin orig_ty1 orig_ty2 go (AppTy s1 t1) (TyConApp tc2 ts2) | Just (ts2', t2') <- snocView ts2 - = assert (not (mustBeSaturated tc2)) $ + = assert (not (tyConMustBeSaturated tc2)) $ go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2' go (TyConApp tc1 ts1) (AppTy s2 t2) | Just (ts1', t1') <- snocView ts1 - = assert (not (mustBeSaturated tc1)) $ + = assert (not (tyConMustBeSaturated tc1)) $ go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2 go (CoercionTy co1) (CoercionTy co2) @@ -2030,7 +2030,7 @@ uUnfilledVar1 :: CtOrigin -> TcTauType -- Type 2, zonked -> TcM Coercion uUnfilledVar1 origin t_or_k swapped tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 + | Just tv2 <- getTyVar_maybe ty2 = go tv2 | otherwise @@ -2077,18 +2077,18 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2 ; if not can_continue_solving then not_ok_so_defer else - do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1) + do { co_k <- uType KindLevel kind_origin (typeKind ty2) (tyVarKind tv1) ; traceTc "uUnfilledVar2 ok" $ vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) - , ppr ty2 <+> dcolon <+> ppr (tcTypeKind ty2) - , ppr (isTcReflCo co_k), ppr co_k ] + , ppr ty2 <+> dcolon <+> ppr (typeKind ty2) + , ppr (isReflCo co_k), ppr co_k ] - ; if isTcReflCo co_k + ; if isReflCo co_k -- Only proceed if the kinds match -- NB: tv1 should still be unfilled, despite the kind unification -- because tv1 is not free in ty2 (or, hence, in its kind) then do { writeMetaTyVar tv1 ty2 - ; return (mkTcNomReflCo ty2) } + ; return (mkNomReflCo ty2) } else defer }} -- This cannot be solved now. See GHC.Tc.Solver.Canonical -- Note [Equalities with incompatible kinds] for how @@ -2134,7 +2134,7 @@ startSolvingByUnification info xi [] -> return True _ -> return False } TyVarTv -> - case tcGetTyVar_maybe xi of + case getTyVar_maybe xi of Nothing -> return False Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle @@ -2516,14 +2516,14 @@ causing this wibble in behavior seen here. matchExpectedFunKind :: TypedThing -- ^ type, only for errors -> Arity -- ^ n: number of desired arrows - -> TcKind -- ^ fun_ kind + -> TcKind -- ^ fun_kind -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) matchExpectedFunKind hs_ty n k = go n k where go 0 k = return (mkNomReflCo k) - go n k | Just k' <- tcView k = go n k' + go n k | Just k' <- coreView k = go n k' go n k@(TyVarTy kvar) | isMetaTyVar kvar @@ -2532,9 +2532,10 @@ matchExpectedFunKind hs_ty n k = go n k Indirect fun_kind -> go n fun_kind Flexi -> defer n k } - go n (FunTy { ft_mult = w, ft_arg = arg, ft_res = res }) + go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + | isVisibleFunArg af = do { co <- go (n-1) res - ; return (mkTcFunCo Nominal (mkTcNomReflCo w) (mkTcNomReflCo arg) co) } + ; return (mkNakedFunCo1 Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) } go n other = defer n other @@ -2658,7 +2659,7 @@ checkTypeEq lhs ty go (LitTy {}) = cteOK go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) = go w S.<> go a S.<> go r S.<> - if not ghci_tv && af == InvisArg + if not ghci_tv && isInvisibleFunArg af then impredicative else cteOK go (AppTy fun arg) = go fun S.<> go arg diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index f57580d3ec..84e0865154 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -57,7 +57,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Types.Evidence -import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Core.TyCo.Ppr ( pprTyVar ) import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion @@ -1009,7 +1009,7 @@ zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) new_ty <- zonkTcTypeToTypeX env ty new_ids <- mapSndM (zonkExpr env) ids - massert (isLiftedTypeKind (tcTypeKind new_stack_tys)) + massert (isLiftedTypeKind (typeKind new_stack_tys)) -- desugarer assumes that this is not representation-polymorphic... -- but indeed it should always be lifted due to the typing -- rules for arrows @@ -1634,7 +1634,7 @@ zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term }) ; term' <- case getEqPredTys_maybe (idType var') of Just (r, ty1, ty2) | ty1 `eqType` ty2 - -> return (evCoercion (mkTcReflCo r ty1)) + -> return (evCoercion (mkReflCo r ty1)) _other -> zonkEvTerm env term ; return (bind { eb_lhs = var', eb_rhs = term' }) } diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 97f9a8384f..5072b8eeff 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -367,7 +367,7 @@ checkValidType :: UserTypeCtxt -> Type -> TcM () -- that is, checkValidType doesn't need to do kind checking -- Not used for instance decls; checkValidInstance instead checkValidType ctxt ty - = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) + = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) ; rankn_flag <- xoptM LangExt.RankNTypes ; impred_flag <- xoptM LangExt.ImpredicativeTypes ; let gen_rank :: Rank -> Rank @@ -433,7 +433,7 @@ checkValidType ctxt ty -- and there may be nested foralls for the subtype test to examine ; checkAmbiguity ctxt ty - ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) } + ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) } checkValidMonoType :: Type -> TcM () -- Assumes argument is fully zonked @@ -446,10 +446,10 @@ checkValidMonoType ty checkTySynRhs :: UserTypeCtxt -> TcType -> TcM () checkTySynRhs ctxt ty - | tcReturnsConstraintKind actual_kind + | returnsConstraintKind actual_kind = do { ck <- xoptM LangExt.ConstraintKinds ; if ck - then when (tcIsConstraintKind actual_kind) + then when (isConstraintLikeKind actual_kind) (do { dflags <- getDynFlags ; expand <- initialExpandMode ; check_pred_ty emptyTidyEnv dflags ctxt expand ty }) @@ -460,7 +460,7 @@ checkTySynRhs ctxt ty | otherwise = return () where - actual_kind = tcTypeKind ty + actual_kind = typeKind ty funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) @@ -761,12 +761,12 @@ check_type ve@(ValidityEnv{ ve_tidy_env = env where (tvbs, phi) = tcSplitForAllTyVarBinders ty (theta, tau) = tcSplitPhiTy phi - (env', _) = tidyTyCoVarBinders env tvbs + (env', _) = tidyForAllTyBinders env tvbs check_type (ve@ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt , ve_rank = rank }) ty@(FunTy _ mult arg_ty res_ty) - = do { failIfTcM (not (linearityAllowed ctxt) && not (isManyDataConTy mult)) + = do { failIfTcM (not (linearityAllowed ctxt) && not (isManyTy mult)) (env, TcRnLinearFuncInKind (tidyType env ty)) ; check_type (ve{ve_rank = arg_rank}) arg_ty ; check_type (ve{ve_rank = res_rank}) res_ty } @@ -818,7 +818,7 @@ check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand }) check_expansion_only expand = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $ - case tcView ty of + case coreView ty of Just ty' -> let err_ctxt = text "In the expansion of type synonym" <+> quotes (ppr tc) in addErrCtxt err_ctxt $ @@ -942,7 +942,7 @@ checkVdqOK ve tvbs ty = do checkTcM (vdqAllowed ctxt || no_vdq) (env, TcRnVDQInTermType (Just (tidyType env ty))) where - no_vdq = all (isInvisibleArgFlag . binderArgFlag) tvbs + no_vdq = all (isInvisibleForAllTyFlag . binderFlag) tvbs ValidityEnv{ve_tidy_env = env, ve_ctxt = ctxt} = ve {- @@ -1086,7 +1086,7 @@ check_pred_help :: Bool -- True <=> under a type synonym -> DynFlags -> UserTypeCtxt -> PredType -> TcM () check_pred_help under_syn env dflags ctxt pred - | Just pred' <- tcView pred -- Switch on under_syn when going under a + | Just pred' <- coreView pred -- Switch on under_syn when going under a -- synonym (#9838, yuk) = check_pred_help True env dflags ctxt pred' @@ -1545,7 +1545,9 @@ tcInstHeadTyAppAllTyVars :: Type -> Bool tcInstHeadTyAppAllTyVars ty | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) = let tys' = filterOutInvisibleTypes tc tys -- avoid kinds - tys'' | tc == funTyCon, tys_h:tys_t <- tys', tys_h `eqType` manyDataConTy = tys_t + tys'' | tc `hasKey` fUNTyConKey + , ManyTy : tys_t <- tys' + = tys_t | otherwise = tys' in ok tys'' | LitTy _ <- ty = True -- accept type literals (#13833) @@ -1556,7 +1558,7 @@ tcInstHeadTyAppAllTyVars ty -- and that each is distinct ok tys = equalLength tvs tys && hasNoDups tvs where - tvs = mapMaybe tcGetTyVar_maybe tys + tvs = mapMaybe getTyVar_maybe tys dropCasts :: Type -> Type -- See Note [Casts during validity checking] @@ -2027,23 +2029,23 @@ checkValidAssocTyFamDeflt fam_tc pats = do { cpt_tvs <- zipWithM extract_tv pats pats_vis ; check_all_distinct_tvs $ zip cpt_tvs pats_vis } where - pats_vis :: [ArgFlag] - pats_vis = tyConArgFlags fam_tc pats + pats_vis :: [ForAllTyFlag] + pats_vis = tyConForAllTyFlags fam_tc pats -- Checks that a pattern on the LHS of a default is a type -- variable. If so, return the underlying type variable, and if -- not, throw an error. -- See Note [Type-checking default assoc decls] - extract_tv :: Type -- The particular type pattern from which to extract - -- its underlying type variable - -> ArgFlag -- The visibility of the type pattern - -- (only used for error message purposes) + extract_tv :: Type -- The particular type pattern from which to + -- extrace its underlying type variable + -> ForAllTyFlag -- The visibility of the type pattern + -- (only used for error message purposes) -> TcM TyVar extract_tv pat pat_vis = case getTyVar_maybe pat of Just tv -> pure tv Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ + pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") 2 (vcat [ppr_eqn, suggestion]) @@ -2051,7 +2053,7 @@ checkValidAssocTyFamDeflt fam_tc pats = -- duplicated. If that is the case, throw an error. -- See Note [Type-checking default assoc decls] check_all_distinct_tvs :: - [(TyVar, ArgFlag)] -- The type variable arguments in the associated + [(TyVar, ForAllTyFlag)] -- The type variable arguments in the associated -- default declaration, along with their respective -- visibilities (the latter are only used for error -- message purposes) @@ -2060,8 +2062,8 @@ checkValidAssocTyFamDeflt fam_tc pats = let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in traverse_ (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ + mkTcRnUnknownMessage $ mkPlainError noHints $ + pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ hang (text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") 2 (vcat [ppr_eqn, suggestion])) @@ -2243,16 +2245,16 @@ checkConsistentFamInst (InClsInst { ai_class = clas where (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch - arg_triples :: [(Type,Type, ArgFlag)] + arg_triples :: [(Type,Type, ForAllTyFlag)] arg_triples = [ (cls_arg_ty, at_arg_ty, vis) | (fam_tc_tv, vis, at_arg_ty) <- zip3 (tyConTyVars fam_tc) - (tyConArgFlags fam_tc ax_arg_tys) + (tyConForAllTyFlags fam_tc ax_arg_tys) ax_arg_tys , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] pp_wrong_at_arg vis - = pprWithExplicitKindsWhen (isInvisibleArgFlag vis) $ + = pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $ vcat [ text "Type indexes must match class instance head" , text "Expected:" <+> pp_expected_ty , text " Actual:" <+> pp_actual_ty ] @@ -2279,7 +2281,7 @@ checkConsistentFamInst (InClsInst { ai_class = clas -- For check_match, bind_me, see -- Note [Matching in the consistent-instantiation check] - check_match :: [(Type,Type,ArgFlag)] -> TcM () + check_match :: [(Type,Type,ForAllTyFlag)] -> TcM () check_match triples = go emptySubst emptySubst triples go _ _ [] = return () @@ -2741,9 +2743,9 @@ checkTyConTelescope tc fkvs = tyCoVarsOfType (tyVarKind tv) inferred_tvs = [ binderVar tcb - | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ] + | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ] specified_tvs = [ binderVar tcb - | tcb <- tcbs, Specified == tyConBinderArgFlag tcb ] + | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ] pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) @@ -2781,7 +2783,7 @@ checkTyConTelescope tc -- Free variables of a type, retaining repetitions, and expanding synonyms -- This ignores coercions, as coercions aren't user-written fvType :: Type -> [TyCoVar] -fvType ty | Just exp_ty <- tcView ty = fvType exp_ty +fvType ty | Just exp_ty <- coreView ty = fvType exp_ty fvType (TyVarTy tv) = [tv] fvType (TyConApp _ tys) = fvTypes tys fvType (LitTy {}) = [] @@ -2798,7 +2800,7 @@ fvTypes tys = concatMap fvType tys sizeType :: Type -> Int -- Size of a type: the number of variables and constructors -sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty +sizeType ty | Just exp_ty <- coreView ty = sizeType exp_ty sizeType (TyVarTy {}) = 1 sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys sizeType (LitTy {}) = 1 diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 11f601cd70..6642ce84b1 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -42,6 +42,7 @@ import GHC.Types.SrcLoc import GHC.Core.Type as Hs import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types +import GHC.Builtin.Types.Prim( fUNTyCon ) import GHC.Types.Basic as Hs import GHC.Types.Fixity as Hs import GHC.Types.ForeignCall @@ -1581,7 +1582,7 @@ cvtTypeKind typeOrKind ty w'' = hsTypeToArrow w' returnLA (HsFunTy noAnn w'' x'' y'') | otherwise - -> do { fun_tc <- returnLA $ getRdrName funTyCon + -> do { fun_tc <- returnLA $ getRdrName fUNTyCon ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } ListT | Just normals <- m_normals diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index d4dcf3cb69..88baab297c 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -49,7 +49,8 @@ module GHC.Types.Basic ( CbvMark(..), isMarkedCbv, - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec, + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, + starPrec, appPrec, maxPrec, maybeParen, TupleSort(..), tupleSortBoxity, boxityTupleSort, @@ -108,6 +109,7 @@ module GHC.Types.Basic ( TypeOrKind(..), isTypeLevel, isKindLevel, Levity(..), mightBeLifted, mightBeUnlifted, + TypeOrConstraint(..), NonStandardDefaultingStrategy(..), DefaultingStrategy(..), defaultNonStandardTyVars, @@ -129,13 +131,11 @@ import qualified Data.Semigroup as Semi import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag) -{- -************************************************************************ +{- ********************************************************************* * * Binary choice * * -************************************************************************ --} +********************************************************************* -} data LeftOrRight = CLeft | CRight deriving( Eq, Data ) @@ -748,16 +748,17 @@ pprSafeOverlap False = empty newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) -- See Note [Precedence in types] -topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec -topPrec = PprPrec 0 -- No parens -sigPrec = PprPrec 1 -- Explicit type signatures -funPrec = PprPrec 2 -- Function args; no parens for constructor apps - -- See [Type operator precedence] for why both - -- funPrec and opPrec exist. -opPrec = PprPrec 2 -- Infix operator +topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec, maxPrec :: PprPrec +topPrec = PprPrec 0 -- No parens +sigPrec = PprPrec 1 -- Explicit type signatures +funPrec = PprPrec 2 -- Function args; no parens for constructor apps + -- See [Type operator precedence] for why both + -- funPrec and opPrec exist. +opPrec = PprPrec 2 -- Infix operator starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *) -- See Note [Star kind precedence] appPrec = PprPrec 4 -- Constructor args; no parens for atomic +maxPrec = appPrec -- Maximum precendence maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc maybeParen ctxt_prec inner_prec pretty @@ -1936,10 +1937,17 @@ isKindLevel KindLevel = True {- ********************************************************************* * * - Levity information + Levity and TypeOrConstraint * * ********************************************************************* -} +{- The types `Levity` and `TypeOrConstraint` are internal to GHC. + They have the same shape as the eponymous types in the library + ghc-prim:GHC.Types + but they aren't the same types -- after all, they are defined in a + different module. +-} + data Levity = Lifted | Unlifted @@ -1957,6 +1965,11 @@ mightBeUnlifted :: Maybe Levity -> Bool mightBeUnlifted (Just Lifted) = False mightBeUnlifted _ = True +data TypeOrConstraint + = TypeLike | ConstraintLike + deriving( Eq, Ord, Data ) + + {- ********************************************************************* * * Defaulting options diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index d79b4acf2f..4744147dcf 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -309,7 +309,7 @@ mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty mkLocalCoVar :: Name -> Type -> CoVar mkLocalCoVar name ty = assert (isCoVarType ty) $ - Var.mkLocalVar CoVarId name Many ty vanillaIdInfo + Var.mkLocalVar CoVarId name ManyTy ty vanillaIdInfo -- | Like 'mkLocalId', but checks the type to see if it should make a covar mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id @@ -377,7 +377,7 @@ instantiated before use. -- | Workers get local names. "CoreTidy" will externalise these if necessary mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId uniq unwrkr ty - = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) Many ty + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ManyTy ty -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings mkTemplateLocal :: Int -> Type -> Id diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 79ae56cd5e..5dd44bd2b1 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -17,7 +17,7 @@ have a standard form, namely: {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Types.Id.Make ( - mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, + mkDictFunId, mkDictSelId, mkDictSelRhs, mkFCallId, @@ -33,7 +33,10 @@ module GHC.Types.Id.Make ( voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, coercionTokenId, coerceId, - proxyHashId, noinlineId, noinlineIdName, nospecId, nospecIdName, + proxyHashId, + nospecId, nospecIdName, + noinlineId, noinlineIdName, + noinlineConstraintId, noinlineConstraintIdName, coerceName, leftSectionName, rightSectionName, ) where @@ -71,7 +74,7 @@ import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.Unique.Supply import GHC.Types.Basic hiding ( SuccessFlag(..) ) -import GHC.Types.Var (VarBndr(Bndr)) +import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike) import GHC.Tc.Utils.TcType as TcType @@ -160,7 +163,7 @@ wiredInIds ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId, nospecId] +magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -308,14 +311,15 @@ for symmetry with the way data instances are handled. Note [Newtype datacons] ~~~~~~~~~~~~~~~~~~~~~~~ -The "data constructor" for a newtype should always be vanilla. At one -point this wasn't true, because the newtype arising from +The "data constructor" for a newtype should have no existentials. It's +not quite a "vanilla" data constructor, because the newtype arising from class C a => D a -looked like - newtype T:D a = D:D (C a) -so the data constructor for T:C had a single argument, namely the -predicate (C a). But now we treat that as an ordinary argument, not -part of the theta-type, so all is well. +looks like + newtype T:D a = C:D (C a) +so the data constructor for T:C has a single argument, namely the +predicate (C a). That ends up in the dcOtherTheta for the data con, +which makes it not vanilla. So the assert just tests for existentials. +The rest is checked by having a singleton arg_tys. Note [Newtype workers] ~~~~~~~~~~~~~~~~~~~~~~ @@ -472,7 +476,7 @@ mkDictSelId name clas val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name sel_ty = mkInvisForAllTys tyvars $ - mkInvisFunTyMany (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ + mkFunctionType ManyTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ scaledThing (getNth arg_tys val_index) -- See Note [Type classes and linear types] @@ -589,8 +593,10 @@ mkDataConWorkId wkr_name data_con wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } wkr_arity = dataConRepArity data_con + ----------- Workers for newtypes -------------- univ_tvs = dataConUnivTyVars data_con + ex_tcvs = dataConExTyCoVars data_con arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 @@ -598,8 +604,8 @@ mkDataConWorkId wkr_name data_con `setUnfoldingInfo` newtype_unf id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) res_ty_args = mkTyCoVarTys univ_tvs - newtype_unf = assertPpr (isVanillaDataCon data_con && isSingleton arg_tys) - (ppr data_con) $ + newtype_unf = assertPpr (null ex_tcvs && isSingleton arg_tys) + (ppr data_con) -- Note [Newtype datacons] mkCompulsoryUnfolding $ mkLams univ_tvs $ Lam id_arg1 $ @@ -740,10 +746,10 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) - = dataConFullSig data_con + = dataConFullSig data_con stupid_theta = dataConStupidTheta data_con wrap_tvs = dataConUserTyVars data_con - res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs + res_ty_args = dataConResRepTyArgs data_con tycon = dataConTyCon data_con -- The representation TyCon (not family) wrap_ty = dataConWrapperType data_con @@ -781,16 +787,16 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con (not new_tycon -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. See below. - && (any isBanged (ev_ibangs ++ arg_ibangs) + && (any isBanged (ev_ibangs ++ arg_ibangs))) -- Some forcing/unboxing (includes eq_spec) - || (not $ null eq_spec))) -- GADT || isFamInstTyCon tycon -- Cast result - || dataConUserTyVarsArePermuted data_con + || dataConUserTyVarsNeedWrapper data_con -- If the data type was written with GADT syntax and -- orders the type variables differently from what the -- worker expects, it needs a data con wrapper to reorder -- the type variables. -- See Note [Data con wrappers and GADT syntax]. + -- NB: All GADTs return true from this function || not (null stupid_theta) -- If the data constructor has a datatype context, -- we need a wrapper in order to drop the stupid arguments. @@ -1329,7 +1335,7 @@ mkFCallId uniq fcall ty `setCprSigInfo` topCprSig (bndrs, _) = tcSplitPiTys ty - arity = count isAnonTyCoBinder bndrs + arity = count isAnonPiTyBinder bndrs strict_sig = mkVanillaDmdSig arity topDiv -- the call does not claim to be strict in its arguments, since they -- may be lifted (foreign import prim) and the called code doesn't @@ -1365,11 +1371,7 @@ mkDictFunId dfun_name tvs theta clas tys dfun_ty where is_nt = isNewTyCon (classTyCon clas) - dfun_ty = mkDictFunTy tvs theta clas tys - -mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type -mkDictFunTy tvs theta clas tys - = mkSpecSigmaTy tvs theta (mkClassPred clas tys) + dfun_ty = TcType.tcMkDFunSigmaTy tvs theta (mkClassPred clas tys) {- ************************************************************************ @@ -1405,10 +1407,9 @@ leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSecti rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, noinlineIdName, nospecIdName :: Name +lazyIdName, oneShotName, nospecIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId -noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId ------------------------------------------------ @@ -1471,12 +1472,28 @@ lazyId = pcMiscPrelId lazyIdName ty info info = noCafIdInfo ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) +------------------------------------------------ +noinlineIdName, noinlineConstraintIdName :: Name +noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") + noinlineIdKey noinlineId +noinlineConstraintIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinlineConstraint") + noinlineConstraintIdKey noinlineConstraintId + noinlineId :: Id -- See Note [noinlineId magic] noinlineId = pcMiscPrelId noinlineIdName ty info where info = noCafIdInfo - ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) + ty = mkSpecForAllTys [alphaTyVar] $ + mkVisFunTyMany alphaTy alphaTy +noinlineConstraintId :: Id -- See Note [noinlineId magic] +noinlineConstraintId = pcMiscPrelId noinlineConstraintIdName ty info + where + info = noCafIdInfo + ty = mkSpecForAllTys [alphaConstraintTyVar] $ + mkFunTy visArgConstraintLike ManyTy alphaTy alphaConstraintTy + +------------------------------------------------ nospecId :: Id -- See Note [nospecId magic] nospecId = pcMiscPrelId nospecIdName ty info where @@ -1562,8 +1579,8 @@ rightSectionId = pcMiscPrelId rightSectionName ty info mult1 = mkTyVarTy multiplicityTyVar1 mult2 = mkTyVarTy multiplicityTyVar2 - [f,x,y] = mkTemplateLocals [ mkVisFunTys [ Scaled mult1 openAlphaTy - , Scaled mult2 openBetaTy ] openGammaTy + [f,x,y] = mkTemplateLocals [ mkScaledFunTys [ Scaled mult1 openAlphaTy + , Scaled mult2 openBetaTy ] openGammaTy , openAlphaTy, openBetaTy ] xmult = setIdMult x mult1 ymult = setIdMult y mult2 @@ -1586,7 +1603,7 @@ coerceId = pcMiscPrelId coerceName ty info ty = mkInvisForAllTys [ Bndr rv InferredSpec , Bndr av SpecifiedSpec , Bndr bv SpecifiedSpec ] $ - mkInvisFunTyMany eqRTy $ + mkInvisFunTy eqRTy $ mkVisFunTyMany a b bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy @@ -1723,20 +1740,31 @@ But actually we give 'noinline' a wired-in name for three distinct reasons: noinline foo x xs where x::Int, will naturally desugar to noinline @Int (foo @Int dEqInt) x xs - But now it's entirely possible htat (foo @Int dEqInt) will inline foo, + But now it's entirely possible that (foo @Int dEqInt) will inline foo, since 'foo' is no longer a lone variable -- see #18995 Solution: in the desugarer, rewrite noinline (f x y) ==> noinline f x y This is done in GHC.HsToCore.Utils.mkCoreAppDs. - -Note that noinline as currently implemented can hide some simplifications since -it hides strictness from the demand analyser. Specifically, the demand analyser -will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f' -specifies that it is strict in its argument. We considered fixing this this by adding a -special case to the demand analyser to address #16588. However, the special -case seemed like a large and expensive hammer to address a rare case and -consequently we rather opted to use a more minimal solution. + This is only needed for noinlineId, not noInlineConstraintId (wrinkle + (W1) below), because the latter never shows up in user code. + +Wrinkles + +(W1) Sometimes case (2) above needs to apply `noinline` to a type of kind + Constraint; e.g. + noinline @(Eq Int) $dfEqInt + We don't have type-or-kind polymorphism, so we simply have two `inline` + Ids, namely `noinlineId` and `noinlineConstraintId`. + +(W2) Note that noinline as currently implemented can hide some simplifications + since it hides strictness from the demand analyser. Specifically, the + demand analyser will treat 'noinline f x' as lazy in 'x', even if the + demand signature of 'f' specifies that it is strict in its argument. We + considered fixing this this by adding a special case to the demand + analyser to address #16588. However, the special case seemed like a large + and expensive hammer to address a rare case and consequently we rather + opted to use a more minimal solution. Note [nospecId magic] ~~~~~~~~~~~~~~~~~~~~~ @@ -1822,7 +1850,7 @@ unboxedUnitExpr :: CoreExpr unboxedUnitExpr = Var (dataConWorkId unboxedUnitDataCon) voidArgId :: Id -- Local lambda-bound :: Void# -voidArgId = mkSysLocal (fsLit "void") voidArgIdKey Many unboxedUnitTy +voidArgId = mkSysLocal (fsLit "void") voidArgIdKey ManyTy unboxedUnitTy coercionTokenId :: Id -- :: () ~# () coercionTokenId -- See Note [Coercion tokens] in "GHC.CoreToStg" diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index 4ece6800ec..7581c10602 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -67,8 +67,9 @@ module GHC.Types.Literal import GHC.Prelude import GHC.Builtin.Types.Prim -import GHC.Core.TyCo.Rep ( RuntimeRepType ) -import GHC.Core.Type +import GHC.Core.Type( Type, RuntimeRepType, mkForAllTy, mkTyVarTy, typeOrConstraintKind ) +import GHC.Core.TyCo.Compare( nonDetCmpType ) +import GHC.Types.Var import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Basic @@ -83,7 +84,7 @@ import Data.Int import Data.Word import Data.Char import Data.Data ( Data ) -import GHC.Exts +import GHC.Exts( isTrue#, dataToTag#, (<#) ) import Numeric ( fromRat ) {- @@ -132,15 +133,14 @@ data Literal -- that can be represented as a Literal. Create -- with 'nullAddrLit' - | LitRubbish RuntimeRepType -- ^ A nonsense value of the given - -- representation. See Note [Rubbish literals]. - -- - -- The Type argument, rr, is of kind RuntimeRep. - -- The type of the literal is forall (a:TYPE rr). a - -- - -- INVARIANT: the Type has no free variables - -- and so substitution etc can ignore it - -- + | LitRubbish -- ^ A nonsense value; See Note [Rubbish literals]. + TypeOrConstraint -- t_or_c: whether this is a type or a constraint + RuntimeRepType -- rr: a type of kind RuntimeRep + -- The type of the literal is forall (a:TYPE rr). a + -- or forall (a:CONSTRAINT rr). a + -- + -- INVARIANT: the Type has no free variables + -- and so substitution etc can ignore it | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' @@ -268,7 +268,7 @@ instance Binary Literal where = do putByte bh 6 put_ bh nt put_ bh i - put_ _ (LitRubbish b) = pprPanic "Binary LitRubbish" (ppr b) + put_ _ lit@(LitRubbish {}) = pprPanic "Binary LitRubbish" (ppr lit) -- We use IfaceLitRubbish; see Note [Rubbish literals], item (6) get bh = do @@ -298,6 +298,7 @@ instance Binary Literal where return (LitNumber nt i) _ -> pprPanic "Binary:Literal" (int (fromIntegral h)) + instance Outputable Literal where ppr = pprLiteral id @@ -851,10 +852,10 @@ literalType (LitNumber lt _) = case lt of LitNumWord64 -> word64PrimTy -- LitRubbish: see Note [Rubbish literals] -literalType (LitRubbish rep) - = mkForAllTy a Inferred (mkTyVarTy a) +literalType (LitRubbish torc rep) + = mkForAllTy (Bndr a Inferred) (mkTyVarTy a) where - a = mkTemplateKindVar (mkTYPEapp rep) + a = mkTemplateKindVar (typeOrConstraintKind torc rep) {- Comparison @@ -870,7 +871,8 @@ cmpLit (LitDouble a) (LitDouble b) = a `compare` b cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `lexicalCompareFS` b cmpLit (LitNumber nt1 a) (LitNumber nt2 b) = (nt1 `compare` nt2) `mappend` (a `compare` b) -cmpLit (LitRubbish b1) (LitRubbish b2) = b1 `nonDetCmpType` b2 +cmpLit (LitRubbish tc1 b1) (LitRubbish tc2 b2) = (tc1 `compare` tc2) `mappend` + (b1 `nonDetCmpType` b2) cmpLit lit1 lit2 | isTrue# (dataToTag# lit1 <# dataToTag# lit2) = LT | otherwise = GT @@ -905,8 +907,12 @@ pprLiteral add_par (LitLabel l mb fod) = where b = case mb of Nothing -> pprHsString l Just x -> doubleQuotes (ftext l <> text ('@':show x)) -pprLiteral _ (LitRubbish rep) - = text "RUBBISH" <> parens (ppr rep) +pprLiteral _ (LitRubbish torc rep) + = text "RUBBISH" <> pp_tc <> parens (ppr rep) + where + pp_tc = case torc of + TypeLike -> empty + ConstraintLike -> text "[c]" {- Note [Printing of literals in Core] @@ -1005,7 +1011,7 @@ data type. Here are the moving parts: all boxed to the host GC anyway. 6. IfaceSyn: `Literal` is part of `IfaceSyn`, but `Type` really isn't. So in - the passage from Core to Iface I put LitRubbish into its owns IfaceExpr data + the passage from Core to Iface we put LitRubbish into its own IfaceExpr data constructor, IfaceLitRubbish. The remaining constructors of Literal are fine as IfaceSyn. diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index 0faf042b4e..51045066d6 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -793,7 +793,6 @@ after we allocate a new one. Note [Tidying multiple names at once] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider > :t (id,id,id) diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs index 1d3bf36aba..3a4dfdc018 100644 --- a/compiler/GHC/Types/Name/Ppr.hs +++ b/compiler/GHC/Types/Name/Ppr.hs @@ -16,12 +16,12 @@ import GHC.Unit.Env import GHC.Types.Name import GHC.Types.Name.Reader -import GHC.Builtin.Types import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Builtin.Types.Prim (tYPETyConName, funTyConName) +import GHC.Builtin.Types.Prim ( fUNTyConName ) +import GHC.Builtin.Types {- @@ -112,7 +112,7 @@ mkPrintUnqualified unit_env env , coercibleTyConName , eqTyConName , tYPETyConName - , funTyConName + , fUNTyConName, unrestrictedFunTyConName , oneDataConName , manyDataConName ] @@ -127,6 +127,7 @@ mkPrintUnqualified unit_env env {- Note [pretendNameIsInScopeForPpr] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c.f. Note [pretendNameIsInScope] in GHC.Builtin.Names Normally, a name is printed unqualified if it's in scope and unambiguous: ghci> :t not not :: Bool -> Bool diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index 30eb12c7a7..d7f0f75219 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -31,7 +31,6 @@ import GHC.Prelude import GHC.Types.Basic (Arity, RepArity) import GHC.Core.DataCon -import GHC.Builtin.Names import GHC.Core.Coercion import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk @@ -56,7 +55,6 @@ import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.List (sort) import qualified Data.IntSet as IS @@ -591,19 +589,16 @@ kindPrimRep doc ki -- NB: We could implement the partial methods by calling into the maybe -- variants here. But then both would need to pass around the doc argument. --- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's +-- | Take a kind (of shape `TYPE rr` or `CONSTRAINT rr`) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] -- Returns Nothing if rep can't be determined. Eg. levity polymorphic types. kindPrimRep_maybe :: HasDebugCallStack => Kind -> Maybe [PrimRep] kindPrimRep_maybe ki - | Just ki' <- coreView ki - = kindPrimRep_maybe ki' -kindPrimRep_maybe (TyConApp typ [runtime_rep]) - = assert (typ `hasKey` tYPETyConKey) $ - runtimeRepPrimRep_maybe runtime_rep -kindPrimRep_maybe _ki - = Nothing + | Just (_torc, rep) <- sORTKind_maybe ki + = runtimeRepPrimRep_maybe rep + | otherwise + = pprPanic "kindPrimRep" (ppr ki) -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep] @@ -613,7 +608,7 @@ runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty = runtimeRepPrimRep doc rr_ty' | TyConApp rr_dc args <- rr_ty - , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc + , RuntimeRep fun <- tyConPromDataConInfo rr_dc = fun args | otherwise = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) @@ -627,7 +622,7 @@ runtimeRepPrimRep_maybe rr_ty | Just rr_ty' <- coreView rr_ty = runtimeRepPrimRep_maybe rr_ty' | TyConApp rr_dc args <- rr_ty - , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc + , RuntimeRep fun <- tyConPromDataConInfo rr_dc = Just $! fun args | otherwise = Nothing diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs index 6cc31ad317..04b6225bd8 100644 --- a/compiler/GHC/Types/TyThing/Ppr.hs +++ b/compiler/GHC/Types/TyThing/Ppr.hs @@ -21,7 +21,7 @@ import GHC.Prelude import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) import GHC.Types.Name -import GHC.Core.Type ( ArgFlag(..), mkTyVarBinders ) +import GHC.Core.Type ( ForAllTyFlag(..), mkTyVarBinders ) import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp ) diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs index 95ecc93539..ca0b45e970 100644 --- a/compiler/GHC/Types/Unique/DFM.hs +++ b/compiler/GHC/Types/Unique/DFM.hs @@ -302,8 +302,12 @@ nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m k' acc (TaggedVal v _) = k v acc eltsUDFM :: UniqDFM key elt -> [elt] -eltsUDFM (UDFM m _i) = - map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m +{-# INLINE eltsUDFM #-} +-- The INLINE makes it a good producer (from the map) +eltsUDFM (UDFM m _i) = map taggedFst (sort_it m) + +sort_it :: M.IntMap (TaggedVal elt) -> [TaggedVal elt] +sort_it m = sortBy (compare `on` taggedSnd) (M.elems m) filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs index dbb739ce1a..494ee70ccf 100644 --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -66,16 +66,30 @@ module GHC.Types.Var ( isGlobalId, isExportedId, mustHaveLocalBinding, - -- * ArgFlags - ArgFlag(Invisible,Required,Specified,Inferred), - AnonArgFlag(..), Specificity(..), - isVisibleArgFlag, isInvisibleArgFlag, isInferredArgFlag, - sameVis, + -- * ForAllTyFlags + ForAllTyFlag(Invisible,Required,Specified,Inferred), + Specificity(..), + isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isInferredForAllTyFlag, + + -- * FunTyFlag + FunTyFlag(..), isVisibleFunArg, isInvisibleFunArg, isFUNArg, + mkFunTyFlag, visArg, invisArg, + visArgTypeLike, visArgConstraintLike, + invisArgTypeLike, invisArgConstraintLike, + funTyFlagResultTypeOrConstraint, + TypeOrConstraint(..), -- Re-export this: it's an argument of FunTyFlag + + -- * PiTyBinder + PiTyBinder(..), PiTyVarBinder, + isInvisiblePiTyBinder, isVisiblePiTyBinder, + isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder, + namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType, -- * TyVar's - VarBndr(..), TyCoVarBinder, TyVarBinder, InvisTVBinder, ReqTVBinder, - binderVar, binderVars, binderArgFlag, binderType, - mkTyCoVarBinder, mkTyCoVarBinders, + VarBndr(..), ForAllTyBinder, TyVarBinder, + InvisTyBinder, InvisTVBinder, ReqTyBinder, ReqTVBinder, + binderVar, binderVars, binderFlag, binderFlags, binderType, + mkForAllTyBinder, mkForAllTyBinders, mkTyVarBinder, mkTyVarBinders, isTyVarBinder, tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders, @@ -96,7 +110,7 @@ module GHC.Types.Var ( import GHC.Prelude -import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind, Mult ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind, Mult, Scaled, scaledThing ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) import {-# SOURCE #-} GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTvUnk ) import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails, @@ -105,6 +119,7 @@ import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique , mkUniqueGrimily, nonDetCmpUnique ) +import GHC.Types.Basic( TypeOrConstraint(..) ) import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Outputable @@ -429,20 +444,20 @@ updateVarTypeM upd var {- ********************************************************************* * * -* ArgFlag +* ForAllTyFlag * * ********************************************************************* -} --- | Argument Flag +-- | ForAllTyFlag -- -- Is something required to appear in source Haskell ('Required'), -- permitted by request ('Specified') (visible type application), or -- prohibited entirely from appearing in source Haskell ('Inferred')? --- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" -data ArgFlag = Invisible Specificity - | Required +-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" +data ForAllTyFlag = Invisible Specificity + | Required deriving (Eq, Ord, Data) - -- (<) on ArgFlag means "is less visible than" + -- (<) on ForAllTyFlag means "is less visible than" -- | Whether an 'Invisible' argument may appear in source Haskell. data Specificity = InferredSpec @@ -453,35 +468,27 @@ data Specificity = InferredSpec -- required. deriving (Eq, Ord, Data) -pattern Inferred, Specified :: ArgFlag +pattern Inferred, Specified :: ForAllTyFlag pattern Inferred = Invisible InferredSpec pattern Specified = Invisible SpecifiedSpec {-# COMPLETE Required, Specified, Inferred #-} --- | Does this 'ArgFlag' classify an argument that is written in Haskell? -isVisibleArgFlag :: ArgFlag -> Bool -isVisibleArgFlag af = not (isInvisibleArgFlag af) - --- | Does this 'ArgFlag' classify an argument that is not written in Haskell? -isInvisibleArgFlag :: ArgFlag -> Bool -isInvisibleArgFlag (Invisible {}) = True -isInvisibleArgFlag Required = False - -isInferredArgFlag :: ArgFlag -> Bool --- More restrictive than isInvisibleArgFlag -isInferredArgFlag (Invisible InferredSpec) = True -isInferredArgFlag _ = False - --- | Do these denote the same level of visibility? 'Required' --- arguments are visible, others are not. So this function --- equates 'Specified' and 'Inferred'. Used for printing. -sameVis :: ArgFlag -> ArgFlag -> Bool -sameVis Required Required = True -sameVis (Invisible _) (Invisible _) = True -sameVis _ _ = False - -instance Outputable ArgFlag where +-- | Does this 'ForAllTyFlag' classify an argument that is written in Haskell? +isVisibleForAllTyFlag :: ForAllTyFlag -> Bool +isVisibleForAllTyFlag af = not (isInvisibleForAllTyFlag af) + +-- | Does this 'ForAllTyFlag' classify an argument that is not written in Haskell? +isInvisibleForAllTyFlag :: ForAllTyFlag -> Bool +isInvisibleForAllTyFlag (Invisible {}) = True +isInvisibleForAllTyFlag Required = False + +isInferredForAllTyFlag :: ForAllTyFlag -> Bool +-- More restrictive than isInvisibleForAllTyFlag +isInferredForAllTyFlag (Invisible InferredSpec) = True +isInferredForAllTyFlag _ = False + +instance Outputable ForAllTyFlag where ppr Required = text "[req]" ppr Specified = text "[spec]" ppr Inferred = text "[infrd]" @@ -496,7 +503,7 @@ instance Binary Specificity where 0 -> return SpecifiedSpec _ -> return InferredSpec -instance Binary ArgFlag where +instance Binary ForAllTyFlag where put_ bh Required = putByte bh 0 put_ bh Specified = putByte bh 1 put_ bh Inferred = putByte bh 2 @@ -508,54 +515,111 @@ instance Binary ArgFlag where 1 -> return Specified _ -> return Inferred --- | The non-dependent version of 'ArgFlag'. --- See Note [AnonArgFlag] --- Appears here partly so that it's together with its friends ArgFlag +{- ********************************************************************* +* * +* FunTyFlag +* * +********************************************************************* -} + +-- | The non-dependent version of 'ForAllTyFlag'. +-- See Note [FunTyFlag] +-- Appears here partly so that it's together with its friends ForAllTyFlag -- and ForallVisFlag, but also because it is used in IfaceType, rather -- early in the compilation chain -data AnonArgFlag - = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. - -- The argument is visible in source code. - | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. - -- The argument is invisible in source code. +data FunTyFlag + = FTF_T_T -- (->) Type -> Type + | FTF_T_C -- (-=>) Type -> Constraint + | FTF_C_T -- (=>) Constraint -> Type + | FTF_C_C -- (==>) Constraint -> Constraint deriving (Eq, Ord, Data) -instance Outputable AnonArgFlag where - ppr VisArg = text "[vis]" - ppr InvisArg = text "[invis]" +instance Outputable FunTyFlag where + ppr FTF_T_T = text "[->]" + ppr FTF_T_C = text "[-=>]" + ppr FTF_C_T = text "[=>]" + ppr FTF_C_C = text "[==>]" -instance Binary AnonArgFlag where - put_ bh VisArg = putByte bh 0 - put_ bh InvisArg = putByte bh 1 +instance Binary FunTyFlag where + put_ bh FTF_T_T = putByte bh 0 + put_ bh FTF_T_C = putByte bh 1 + put_ bh FTF_C_T = putByte bh 2 + put_ bh FTF_C_C = putByte bh 3 get bh = do h <- getByte bh case h of - 0 -> return VisArg - _ -> return InvisArg + 0 -> return FTF_T_T + 1 -> return FTF_T_C + 2 -> return FTF_C_T + _ -> return FTF_C_C + +mkFunTyFlag :: TypeOrConstraint -> TypeOrConstraint -> FunTyFlag +mkFunTyFlag TypeLike torc = visArg torc +mkFunTyFlag ConstraintLike torc = invisArg torc + +visArg :: TypeOrConstraint -> FunTyFlag +visArg TypeLike = FTF_T_T +visArg ConstraintLike = FTF_T_C + +visArgTypeLike :: FunTyFlag +visArgTypeLike = FTF_T_T + +visArgConstraintLike :: FunTyFlag +visArgConstraintLike = FTF_T_C + +invisArg :: TypeOrConstraint -> FunTyFlag +invisArg TypeLike = FTF_C_T +invisArg ConstraintLike = FTF_C_C + +invisArgTypeLike :: FunTyFlag +invisArgTypeLike = FTF_C_T + +invisArgConstraintLike :: FunTyFlag +invisArgConstraintLike = FTF_C_C + +isInvisibleFunArg :: FunTyFlag -> Bool +isInvisibleFunArg af = not (isVisibleFunArg af) + +isVisibleFunArg :: FunTyFlag -> Bool +isVisibleFunArg FTF_T_T = True +isVisibleFunArg FTF_T_C = True +isVisibleFunArg _ = False + +isFUNArg :: FunTyFlag -> Bool +-- This one, FUN, or (->), has an extra multiplicity argument +isFUNArg FTF_T_T = True +isFUNArg _ = False + +funTyFlagResultTypeOrConstraint :: FunTyFlag -> TypeOrConstraint +-- Whether it /returns/ a type or a constraint +funTyFlagResultTypeOrConstraint FTF_T_T = TypeLike +funTyFlagResultTypeOrConstraint FTF_C_T = TypeLike +funTyFlagResultTypeOrConstraint _ = ConstraintLike -{- Note [AnonArgFlag] +{- Note [FunTyFlag] ~~~~~~~~~~~~~~~~~~~~~ -AnonArgFlag is used principally in the FunTy constructor of Type. - FunTy VisArg t1 t2 means t1 -> t2 - FunTy InvisArg t1 t2 means t1 => t2 +FunTyFlag is used principally in the FunTy constructor of Type. + FunTy FTF_T_T t1 t2 means t1 -> t2 + FunTy FTF_C_T t1 t2 means t1 => t2 + FunTy FTF_T_C t1 t2 means t1 -=> t2 + FunTy FTF_C_C t1 t2 means t1 ==> t2 -However, the AnonArgFlag in a FunTy is just redundant, cached +However, the FunTyFlag in a FunTy is just redundant, cached information. In (FunTy { ft_af = af, ft_arg = t1, ft_res = t2 }) - * if (isPredTy t1 = True) then af = InvisArg - * if (isPredTy t1 = False) then af = VisArg + --------------------------------------------- + (isPredTy t1) (isPredTy ty) FunTyFlag + --------------------------------------------- + False False FTF_T_T + False True FTF_T_C + True False FTF_C_T + True True FTF_C_C where isPredTy is defined in GHC.Core.Type, and sees if t1's -kind is Constraint. See GHC.Core.TyCo.Rep -Note [Types for coercions, predicates, and evidence] - -GHC.Core.Utils.mkFunctionType :: Mult -> Type -> Type -> Type -uses isPredTy to decide the AnonArgFlag for the FunTy. +kind is Constraint. See GHC.Core.Type.chooseFunTyFlag, and +GHC.Core.TyCo.Rep Note [Types for coercions, predicates, and evidence] -The term (Lam b e), and coercion (FunCo co1 co2) don't carry -AnonArgFlags; instead they use mkFunctionType when we want to -get their types; see mkLamType and coercionLKind/RKind resp. -This is just an engineering choice; we could cache here too -if we wanted. +The term (Lam b e) donesn't carry an FunTyFlag; instead it uses +mkFunctionType when we want to get its types; see mkLamType. This is +just an engineering choice; we could cache here too if we wanted. Why bother with all this? After all, we are in Core, where (=>) and (->) behave the same. We maintain this distinction throughout Core so @@ -591,7 +655,7 @@ Note [Types for coercions, predicates, and evidence] {- ********************************************************************* * * -* VarBndr, TyCoVarBinder +* VarBndr, ForAllTyBinder * * ********************************************************************* -} @@ -600,29 +664,29 @@ Note [Types for coercions, predicates, and evidence] VarBndr is polymorphic in both var and visibility fields. Currently there are nine different uses of 'VarBndr': -* Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag +* Var.ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag Binder of a forall-type; see ForAllTy in GHC.Core.TyCo.Rep -* Var.TyVarBinder = VarBndr TyVar ArgFlag - Subset of TyCoVarBinder when we are sure the binder is a TyVar +* Var.TyVarBinder = VarBndr TyVar ForAllTyFlag + Subset of ForAllTyBinder when we are sure the binder is a TyVar * Var.InvisTVBinder = VarBndr TyVar Specificity - Specialised form of TyVarBinder, when ArgFlag = Invisible s + Specialised form of TyVarBinder, when ForAllTyFlag = Invisible s See GHC.Core.Type.splitForAllInvisTVBinders * Var.ReqTVBinder = VarBndr TyVar () - Specialised form of TyVarBinder, when ArgFlag = Required + Specialised form of TyVarBinder, when ForAllTyFlag = Required See GHC.Core.Type.splitForAllReqTVBinders This one is barely used * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis Binders of a TyCon; see TyCon in GHC.Core.TyCon -* TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis +* TyCon.TyConPiTyBinder = VarBndr TyCoVar TyConBndrVis Binders of a PromotedDataCon See Note [Promoted GADT data constructors] in GHC.Core.TyCon -* IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +* IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag * IfaceType.IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -} @@ -633,26 +697,29 @@ data VarBndr var argf = Bndr var argf -- | Variable Binder -- --- A 'TyCoVarBinder' is the binder of a ForAllTy +-- A 'ForAllTyBinder' is the binder of a ForAllTy -- It's convenient to define this synonym here rather its natural -- home in "GHC.Core.TyCo.Rep", because it's used in GHC.Core.DataCon.hs-boot -- -- A 'TyVarBinder' is a binder with only TyVar -type TyCoVarBinder = VarBndr TyCoVar ArgFlag -type TyVarBinder = VarBndr TyVar ArgFlag -type InvisTVBinder = VarBndr TyVar Specificity -type ReqTVBinder = VarBndr TyVar () +type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag +type InvisTyBinder = VarBndr TyCoVar Specificity +type ReqTyBinder = VarBndr TyCoVar () + +type TyVarBinder = VarBndr TyVar ForAllTyFlag +type InvisTVBinder = VarBndr TyVar Specificity +type ReqTVBinder = VarBndr TyVar () -tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ArgFlag] +tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ForAllTyFlag] tyVarSpecToBinders = map tyVarSpecToBinder -tyVarSpecToBinder :: VarBndr a Specificity -> VarBndr a ArgFlag +tyVarSpecToBinder :: VarBndr a Specificity -> VarBndr a ForAllTyFlag tyVarSpecToBinder (Bndr tv vis) = Bndr tv (Invisible vis) -tyVarReqToBinders :: [VarBndr a ()] -> [VarBndr a ArgFlag] +tyVarReqToBinders :: [VarBndr a ()] -> [VarBndr a ForAllTyFlag] tyVarReqToBinders = map tyVarReqToBinder -tyVarReqToBinder :: VarBndr a () -> VarBndr a ArgFlag +tyVarReqToBinder :: VarBndr a () -> VarBndr a ForAllTyFlag tyVarReqToBinder (Bndr tv _) = Bndr tv Required binderVar :: VarBndr tv argf -> tv @@ -661,15 +728,21 @@ binderVar (Bndr v _) = v binderVars :: [VarBndr tv argf] -> [tv] binderVars tvbs = map binderVar tvbs -binderArgFlag :: VarBndr tv argf -> argf -binderArgFlag (Bndr _ argf) = argf +binderFlag :: VarBndr tv argf -> argf +binderFlag (Bndr _ argf) = argf + +binderFlags :: [VarBndr tv argf] -> [argf] +binderFlags tvbs = map binderFlag tvbs binderType :: VarBndr TyCoVar argf -> Type binderType (Bndr tv _) = varType tv +isTyVarBinder :: VarBndr TyCoVar vis -> Bool +isTyVarBinder (Bndr tcv _) = isTyVar tcv + -- | Make a named binder -mkTyCoVarBinder :: vis -> TyCoVar -> VarBndr TyCoVar vis -mkTyCoVarBinder vis var = Bndr var vis +mkForAllTyBinder :: vis -> TyCoVar -> VarBndr TyCoVar vis +mkForAllTyBinder vis var = Bndr var vis -- | Make a named binder -- 'var' should be a type variable @@ -679,24 +752,21 @@ mkTyVarBinder vis var Bndr var vis -- | Make many named binders -mkTyCoVarBinders :: vis -> [TyCoVar] -> [VarBndr TyCoVar vis] -mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) +mkForAllTyBinders :: vis -> [TyCoVar] -> [VarBndr TyCoVar vis] +mkForAllTyBinders vis = map (mkForAllTyBinder vis) -- | Make many named binders -- Input vars should be type variables mkTyVarBinders :: vis -> [TyVar] -> [VarBndr TyVar vis] mkTyVarBinders vis = map (mkTyVarBinder vis) -isTyVarBinder :: TyCoVarBinder -> Bool -isTyVarBinder (Bndr v _) = isTyVar v - mapVarBndr :: (var -> var') -> (VarBndr var flag) -> (VarBndr var' flag) mapVarBndr f (Bndr v fl) = Bndr (f v) fl mapVarBndrs :: (var -> var') -> [VarBndr var flag] -> [VarBndr var' flag] mapVarBndrs f = map (mapVarBndr f) -instance Outputable tv => Outputable (VarBndr tv ArgFlag) where +instance Outputable tv => Outputable (VarBndr tv ForAllTyFlag) where ppr (Bndr v Required) = ppr v ppr (Bndr v Specified) = char '@' <> ppr v ppr (Bndr v Inferred) = braces (ppr v) @@ -712,6 +782,270 @@ instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where instance NamedThing tv => NamedThing (VarBndr tv flag) where getName (Bndr tv _) = getName tv + +{- ********************************************************************** +* * + PiTyBinder +* * +********************************************************************** -} + +-- | A 'PiTyBinder' represents an argument to a function. PiTyBinders can be +-- dependent ('Named') or nondependent ('Anon'). They may also be visible or +-- not. See Note [PiTyBinders] +data PiTyBinder + = Named ForAllTyBinder -- A type-lambda binder, with a ForAllTyFlag + | Anon (Scaled Type) FunTyFlag -- A term-lambda binder. Type here can be CoercionTy. + -- The arrow is described by the FunTyFlag + deriving Data + +instance Outputable PiTyBinder where + ppr (Anon ty af) = ppr af <+> ppr ty + ppr (Named (Bndr v Required)) = ppr v + ppr (Named (Bndr v Specified)) = char '@' <> ppr v + ppr (Named (Bndr v Inferred)) = braces (ppr v) + + +-- | 'PiTyVarBinder' is like 'PiTyBinder', but there can only be 'TyVar' +-- in the 'Named' field. +type PiTyVarBinder = PiTyBinder + +-- | Does this binder bind an invisible argument? +isInvisiblePiTyBinder :: PiTyBinder -> Bool +isInvisiblePiTyBinder (Named (Bndr _ vis)) = isInvisibleForAllTyFlag vis +isInvisiblePiTyBinder (Anon _ af) = isInvisibleFunArg af + +-- | Does this binder bind a visible argument? +isVisiblePiTyBinder :: PiTyBinder -> Bool +isVisiblePiTyBinder = not . isInvisiblePiTyBinder + +isNamedPiTyBinder :: PiTyBinder -> Bool +isNamedPiTyBinder (Named {}) = True +isNamedPiTyBinder (Anon {}) = False + +namedPiTyBinder_maybe :: PiTyBinder -> Maybe TyCoVar +namedPiTyBinder_maybe (Named tv) = Just $ binderVar tv +namedPiTyBinder_maybe _ = Nothing + +-- | Does this binder bind a variable that is /not/ erased? Returns +-- 'True' for anonymous binders. +isAnonPiTyBinder :: PiTyBinder -> Bool +isAnonPiTyBinder (Named {}) = False +isAnonPiTyBinder (Anon {}) = True + +-- | Extract a relevant type, if there is one. +anonPiTyBinderType_maybe :: PiTyBinder -> Maybe Type +anonPiTyBinderType_maybe (Named {}) = Nothing +anonPiTyBinderType_maybe (Anon ty _) = Just (scaledThing ty) + +-- | If its a named binder, is the binder a tyvar? +-- Returns True for nondependent binder. +-- This check that we're really returning a *Ty*Binder (as opposed to a +-- coercion binder). That way, if/when we allow coercion quantification +-- in more places, we'll know we missed updating some function. +isTyBinder :: PiTyBinder -> Bool +isTyBinder (Named bnd) = isTyVarBinder bnd +isTyBinder _ = True + +piTyBinderType :: PiTyBinder -> Type +piTyBinderType (Named (Bndr tv _)) = varType tv +piTyBinderType (Anon ty _) = scaledThing ty + +{- Note [PiTyBinders] +~~~~~~~~~~~~~~~~~~~ +But a type like + forall a. Maybe a -> forall b. (a,b) -> b + +can be decomposed to a telescope of type [PiTyBinder], using splitPiTys. +That function splits off all leading foralls and arrows, giving + ([Named a, Anon (Maybe a), Named b, Anon (a,b)], b) + +A PiTyBinder represents the type of binders -- that is, the type of an +argument to a Pi-type. GHC Core currently supports two different +Pi-types: + + * Anon ty1 fun_flag: a non-dependent function type, + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. These are + lifted to Coercions with the corresponding FunCo. + + * Named (Var tv forall_flag) + A dependent compile-time-only polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty + +Both forms of Pi-types classify terms/types that take an argument. In other +words, if `x` is either a function or a polytype, `x arg` makes sense +(for an appropriate `arg`). + +Wrinkles + +* The Anon constructor of PiTyBinder contains a FunTyFlag. Since + the PiTyBinder really only describes the /argument/ it should perhaps + only have a TypeOrConstraint rather than a full FunTyFlag. But it's + very convenient to have the full FunTyFlag, say in mkPiTys, so that's + what we do. + + +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A ForAllTy (used for both types and kinds) contains a ForAllTyBinder. + Each ForAllTyBinder + Bndr a tvis + is equipped with tvis::ForAllTyFlag, which says whether or not arguments + for this binder should be visible (explicit) in source Haskell. + +* A TyCon contains a list of TyConBinders. Each TyConBinder + Bndr a cvis + is equipped with cvis::TyConBndrVis, which says whether or not type + and kind arguments for this TyCon should be visible (explicit) in + source Haskell. + +This table summarises the visibility rules: +--------------------------------------------------------------------------------------- +| Occurrences look like this +| GHC displays type as in Haskell source code +|-------------------------------------------------------------------------------------- +| Bndr a tvis :: ForAllTyBinder, in the binder of ForAllTy for a term +| tvis :: ForAllTyFlag +| tvis = Inferred: f :: forall {a}. type Arg not allowed: f + f :: forall {co}. type Arg not allowed: f +| tvis = Specified: f :: forall a. type Arg optional: f or f @Int +| tvis = Required: T :: forall k -> type Arg required: T * +| This last form is illegal in terms: See Note [No Required PiTyBinder in terms] +| +| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon +| cvis :: TyConBndrVis +| cvis = AnonTCB: T :: kind -> kind Required: T * +| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T +| T :: forall {co}. kind Arg not allowed: T +| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T +| cvis = NamedTCB Required: T :: forall k -> kind Required: T * +--------------------------------------------------------------------------------------- + +[1] In types, in the Specified case, it would make sense to allow + optional kind applications, thus (T @*), but we have not + yet implemented that + +---- In term declarations ---- + +* Inferred. Function defn, with no signature: f1 x = x + We infer f1 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because it doesn't appear in any + user-written signature for f1 + +* Specified. Function defn, with signature (implicit forall): + f2 :: a -> a; f2 x = x + So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified + even though 'a' is not bound in the source code by an explicit forall + +* Specified. Function defn, with signature (explicit forall): + f3 :: forall a. a -> a; f3 x = x + So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified + +* Inferred. Function defn, with signature (explicit forall), marked as inferred: + f4 :: forall {a}. a -> a; f4 x = x + So f4 gets the type f4 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because the user marked it as such, even though it does appear + in the user-written signature for f4 + +* Inferred/Specified. Function signature with inferred kind polymorphism. + f5 :: a b -> Int + So 'f5' gets the type f5 :: forall {k} (a:k->*) (b:k). a b -> Int + Here 'k' is Inferred (it's not mentioned in the type), + but 'a' and 'b' are Specified. + +* Specified. Function signature with explicit kind polymorphism + f6 :: a (b :: k) -> Int + This time 'k' is Specified, because it is mentioned explicitly, + so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int + +* Similarly pattern synonyms: + Inferred - from inferred types (e.g. no pattern type signature) + - or from inferred kind polymorphism + +---- In type declarations ---- + +* Inferred (k) + data T1 a b = MkT1 (a b) + Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * + The kind variable 'k' is Inferred, since it is not mentioned + + Note that 'a' and 'b' correspond to /Anon/ PiTyBinders in T1's kind, + and Anon binders don't have a visibility flag. (Or you could think + of Anon having an implicit Required flag.) + +* Specified (k) + data T2 (a::k->*) b = MkT (a b) + Here T's kind is T :: forall (k:*). (k->*) -> k -> * + The kind variable 'k' is Specified, since it is mentioned in + the signature. + +* Required (k) + data T k (a::k->*) b = MkT (a b) + Here T's kind is T :: forall k:* -> (k->*) -> k -> * + The kind is Required, since it bound in a positional way in T's declaration + Every use of T must be explicitly applied to a kind + +* Inferred (k1), Specified (k) + data T a b (c :: k) = MkT (a b) (Proxy c) + Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * + So 'k' is Specified, because it appears explicitly, + but 'k1' is Inferred, because it does not + +Generally, in the list of TyConBinders for a TyCon, + +* Inferred arguments always come first +* Specified, Anon and Required can be mixed + +e.g. + data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... + +Here Foo's TyConBinders are + [Required 'a', Specified 'b', Anon] +and its kind prints as + Foo :: forall a -> forall b. (a -> b -> Type) -> Type + +See also Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + +---- Printing ----- + + We print forall types with enough syntax to tell you their visibility + flag. But this is not source Haskell, and these types may not all + be parsable. + + Specified: a list of Specified binders is written between `forall` and `.`: + const :: forall a b. a -> b -> a + + Inferred: like Specified, but every binder is written in braces: + f :: forall {k} (a:k). S k a -> Int + + Required: binders are put between `forall` and `->`: + T :: forall k -> * + +---- Other points ----- + +* In classic Haskell, all named binders (that is, the type variables in + a polymorphic function type f :: forall a. a -> a) have been Inferred. + +* Inferred variables correspond to "generalized" variables from the + Visible Type Applications paper (ESOP'16). + +Note [No Required PiTyBinder in terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow Required foralls for term variables, including pattern +synonyms and data constructors. Why? Because then an application +would need a /compulsory/ type argument (possibly without an "@"?), +thus (f Int); and we don't have concrete syntax for that. + +We could change this decision, but Required, Named PiTyBinders are rare +anyway. (Most are Anons.) + +However the type of a term can (just about) have a required quantifier; +see Note [Required quantifiers in the type of a term] in GHC.Tc.Gen.Expr. +-} + + + {- ************************************************************************ * * diff --git a/compiler/GHC/Types/Var.hs-boot b/compiler/GHC/Types/Var.hs-boot index 1882a86d33..ab28bb7659 100644 --- a/compiler/GHC/Types/Var.hs-boot +++ b/compiler/GHC/Types/Var.hs-boot @@ -9,8 +9,8 @@ import {-# SOURCE #-} GHC.Types.Name -- otherwise-unnecessary import tells the build system that this module -- depends on GhcPrelude, which ensures that GHC.Type is built first. -data ArgFlag -data AnonArgFlag +data ForAllTyFlag +data FunTyFlag data Var instance NamedThing Var data VarBndr var argf diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index 96ca5d53a6..2704a2b39b 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -23,7 +23,7 @@ module GHC.Types.Var.Env ( isEmptyVarEnv, elemVarEnvByKey, filterVarEnv, restrictVarEnv, - partitionVarEnv, + partitionVarEnv, varEnvDomain, -- * Deterministic Var environments (maps) DVarEnv, DIdEnv, DTyVarEnv, @@ -83,6 +83,7 @@ import GHC.Types.Name.Occurrence import GHC.Types.Name import GHC.Types.Var as Var import GHC.Types.Var.Set +import GHC.Data.Graph.UnVar -- UnVarSet import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique.DFM @@ -505,6 +506,7 @@ extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a +varEnvDomain :: VarEnv elt -> UnVarSet partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) -- | Only keep variables contained in the VarSet @@ -561,7 +563,9 @@ mkVarEnv_Directly= listToUFM_Directly emptyVarEnv = emptyUFM unitVarEnv = unitUFM isEmptyVarEnv = isNullUFM -partitionVarEnv = partitionUFM +partitionVarEnv = partitionUFM +varEnvDomain = domUFMUnVarSet + restrictVarEnv env vs = filterUFM_Directly keep env where diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs index 0774a5f1c3..94d9e7cefd 100644 --- a/compiler/GHC/Utils/Panic.hs +++ b/compiler/GHC/Utils/Panic.hs @@ -34,6 +34,7 @@ module GHC.Utils.Panic , assertPanic , assertPprPanic , assertPpr + , assertPprMaybe , assertPprM , massertPpr @@ -316,6 +317,12 @@ assertPpr cond msg a = then withFrozenCallStack (assertPprPanic msg) else a +assertPprMaybe :: HasCallStack => Maybe SDoc -> a -> a +{-# INLINE assertPprMaybe #-} +assertPprMaybe mb_msg a + | debugIsOn, Just msg <- mb_msg = withFrozenCallStack (assertPprPanic msg) + | otherwise = a + massertPpr :: (HasCallStack, Applicative m) => Bool -> SDoc -> m () {-# INLINE massertPpr #-} massertPpr cond msg = withFrozenCallStack (assertPpr cond msg (pure ())) diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 24e2ceeecc..69cf084421 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -906,8 +906,10 @@ data HsTyLit pass data HsArrow pass = HsUnrestrictedArrow !(LHsUniToken "->" "→" pass) -- ^ a -> b or a → b + | HsLinearArrow !(HsLinearArrowTokens pass) -- ^ a %1 -> b or a %1 → b, or a ⊸ b + | HsExplicitMult !(LHsToken "%" pass) !(LHsType pass) !(LHsUniToken "->" "→" pass) -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`! -- This is how the programmer wrote it). It is stored as an diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index de013e5d32..a867801951 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -348,6 +348,7 @@ Library GHC.CoreToStg GHC.CoreToStg.Prep GHC.Core.TyCo.FVs + GHC.Core.TyCo.Compare GHC.Core.TyCon GHC.Core.TyCon.Env GHC.Core.TyCon.RecWalk |